Excel - VBA - Email + attachement

Misterbean1 Messages postés 53 Statut Membre -  
Misterbean1 Messages postés 53 Statut Membre -
Bonjour,
Voici ma question car je rame, rame, rame et suis un grand novice en VBA....
La macro dont code ci-dessous me permet de créer un Email et ajouter dans le corps de l'Email une image d'une sélection de cellules (A4:B20) seulement, je voudrais également que la sélection de cellules en question soient EGALEMENT en annexe (attachement) du l'Email sous forme de tableau classique xls

Pouvez-vous aider svp, je n'arrive pas à trouver la solution.....

---> le code ci-dessous permet déjà de sauver la page dans un workbook séparé (ce qui en soit n'est pas nécessaire pour moi mais bon...), mais ne l'attache pas à l'Email, il y a certainement des inconsistances ou erreurs...


d'avance un grand merci !!

************************** 


Sub Mail_Selection_Range_FSC()

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("FSC").Range("A4:B20")
    
    On Error GoTo 0

If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
               vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set Sourcewb = ActiveWorkbook

    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007-2013
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With

    '    'Change all cells in the worksheet to values if you want
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
 
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .to = Worksheets("FSC").Range("E1").Value
        .CC = Worksheets("FSC").Range("E2").Value
        .BCC = ""
        .Subject = "FSC Prolongation" & "__" & Worksheets("FSC").Range("B4") & "__" & Worksheets("FSC").Range("B7")
        .HTMLBody = RangetoHTML(rng)
        .Attachements.Add WB.FullName
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
A voir également:

2 réponses

Réponse 1 / 2
f894009 Messages postés 17414 Date d'inscription   Statut Membre Dernière intervention   1 715
 
Bonjour,

code un peu simplifie(pas top car pourrait etre plus simple, mais a vous de jouer), heureusement j'ai trouve ou vous avez recupere ce code, car manquait la fonction RangetoHTML(rng). Ce qu'il faut retenir pour l'attachments, c'est que le ou les fichiers pieces-jointes doivent etre enregistres sur disques

https://docs.microsoft.com/fr-fr/office/vba/api/outlook.attachments.add?redirectedfrom=MSDN 

Sub Mail_Selection_Range_FSC()

    Dim Rng As Range
    'Dim OutApp As Object
    'Dim OutMail As Object
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    
    Set Rng = Nothing
    On Error Resume Next
    Set Rng = Sheets("FSC").Range("A4:B20")
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
                        vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set Sourcewb = ActiveWorkbook
        
    'Copy the ActiveSheet to a new workbook
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    'Save the new workbook/Mail
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = ".xlsx": FileFormatNum = 51
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close SaveChanges:=False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Worksheets("FSC").Range("E1").Value
        .CC = Worksheets("FSC").Range("E2").Value
        .BCC = ""
        .Subject = "FSC Prolongation" & "__" & Worksheets("FSC").Range("B4") & "__" & Worksheets("FSC").Range("B7")
        .HTMLBody = RangetoHTML(Rng)
        'piece-jointe doit etre obligatoirement enregistree sur disque
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
0
Misterbean1 Messages postés 53 Statut Membre 1
 
Merci f894009! cela fonctionne maintenant. ceci dit, j'ai dû réactiver
Dim OutApp As Object et Dim OutMail As Object et supprimer Dim OutApp As Outlook.Application et Dim OutMail As Outlook.MailItem car mon Excel 2013 m'indiquait des erreurs. E n tout cas, merci pour cette aide précieuse.

Puis-je encore abuser (un peu)? Plutôt que copier la feuille active entière pour la coller ailleurs, j'aimerais que la copie se fasse sur le Range défini plus haut (pour le html)

Puis-je remplacer le code Activesheet . copy ? Si oui, comment intégrer le Range ("A4:B20") car je n'arrive pas à intégrer un code qui tient la route (VBA retourne une erreur sur ".SaveAs TempFilePath & TempFileName & FileExtStr," si je remplace Activesheet . Copy

D'avance encore merci !!
0
f894009 Messages postés 17414 Date d'inscription   Statut Membre Dernière intervention   1 715 > Misterbean1 Messages postés 53 Statut Membre
 
Bonjour, 

Dim OutApp As Object et Dim OutMail As Object

Vos trouverez l'explication sur le site ou vous avez recupere votre code en bas de page, chez moi je dois ecrire ces lignes et vous les votres suivant nos config de references.

Pour votre copy de range, je regarde la chose

A+
0
Réponse 2 / 2
f894009 Messages postés 17414 Date d'inscription   Statut Membre Dernière intervention   1 715
 
Re, 

Sub Mail_Selection_Range_FSC()

    Dim Rng As Range
    'Dim OutApp As Object
    'Dim OutMail As Object
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    
    Set Rng = Nothing
    On Error Resume Next
    Set Rng = Sheets("FSC").Range("A4:B20")
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
                        vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set Sourcewb = ActiveWorkbook
        
    'Copie de la plage de cellules dans un nouveau classeur
    Set Destwb = Workbooks.Add
    'deux transposes pour remettre le tableau dans le bon sens
    Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count) = Application.Transpose(Application.Transpose(Rng))
    'Save the new workbook/Mail
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = ".xlsx": FileFormatNum = 51
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close SaveChanges:=False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Worksheets("FSC").Range("E1").Value
        .CC = Worksheets("FSC").Range("E2").Value
        .BCC = ""
        .Subject = "FSC Prolongation" & "__" & Worksheets("FSC").Range("B4") & "__" & Worksheets("FSC").Range("B7")
        .HTMLBody = RangetoHTML(Rng)
        'piece-jointe doit etre obligatoirement enregistree sur disque
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
0
Misterbean1 Messages postés 53 Statut Membre 1
 
merci f894009 pour cette réponse rapide et je confirme que cela fonctionne.
malheureusement le format n'est pas conservé (c'est du texte/contenu brut).... y a-t-il une solution pour que le formatage soit conserver.....au risque d'abuser vraiment.....

Merci à vous
0
f894009 Messages postés 17414 Date d'inscription   Statut Membre Dernière intervention   1 715 > Misterbean1 Messages postés 53 Statut Membre
 
Re, 

Sub Mail_Selection_Range_FSC()

    Dim Rng As Range
    'Dim OutApp As Object
    'Dim OutMail As Object
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    
    Set Rng = Nothing
    On Error Resume Next
    Set Rng = Sheets("FSC").Range("A4:B20")
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected. " & _
                        vbNewLine & "Please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        '.ScreenUpdating = False
    End With

    Set Sourcewb = ActiveWorkbook
        
    'Copie de la plage de cellules dans un nouveau classeur
    Set Destwb = Workbooks.Add
    'copy avec format
    Sourcewb.Sheets("FSC").Range("A4:B20").Copy Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count)
    'deux transposes pour remettre le tableau dans le bon sens
    'Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count) = Application.Transpose(Application.Transpose(Rng))
    'Save the new workbook/Mail
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    FileExtStr = ".xlsx": FileFormatNum = 51
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        .Close SaveChanges:=False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Worksheets("FSC").Range("E1").Value
        .CC = Worksheets("FSC").Range("E2").Value
        .BCC = ""
        .Subject = "FSC Prolongation" & "__" & Worksheets("FSC").Range("B4") & "__" & Worksheets("FSC").Range("B7")
        .HTMLBody = RangetoHTML(Rng)
        'piece-jointe doit etre obligatoirement enregistree sur disque
        .Attachments.Add TempFilePath & TempFileName & FileExtStr
        .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
0
Misterbean1 Messages postés 53 Statut Membre 1
 
S'il y avait un code VBA pour dire Milles Merci, je l'étudierais par coeur.

Merci bcp f894009 !!
0
Misterbean1 Messages postés 53 Statut Membre 1
 
F894009,
Encore une petite question ..... rien de bien méchant (j'espère). Je constate que le range de cellule copié est bien collé dans le worksheet temporaire , mais la taille des cellules d'accueil reste la taille d'origine, ce qui compresse le contenu dans la taille en question (alors qu'à l'origine, la taille des cellules est adaptée au contenu), est-il possible de coder afin que la taille des cellules s'adapte ou pas possible ?

D'avance merci
MB
0
f894009 Messages postés 17414 Date d'inscription   Statut Membre Dernière intervention   1 715
 
Bonjour,

Vous pouvez me la refaire???

Si colonnes ajustees: joutez ligne en gras 

   'copy avec format
    Sourcewb.Sheets("FSC").Range("A4:B20").Copy Destwb.ActiveSheet.Range("A1").Resize(Rng.Rows.Count, Rng.Columns.Count)
    'colonnes ajustees
    Destwb.ActiveSheet.Cells.EntireColumn.AutoFit
0