Bonjour,
Je cherche à automatiser l'envoi d'un mail à une liste de contact prè-établie.
Je souhaite que le mail soit sous cette forme :
"Bonjour,"
"Voici le résultat :"
coller l'image du tableau excel
"Merci,"
insérer la signature mail.
J'ai le code ci-dessous, je ne suis pas loin du but, mais pour le moment, cela s'affiche dans le désordre.
Pouvez-vous m'aider svp ?
Merci.
JL
Je cherche à automatiser l'envoi d'un mail à une liste de contact prè-établie.
Je souhaite que le mail soit sous cette forme :
"Bonjour,"
"Voici le résultat :"
coller l'image du tableau excel
"Merci,"
insérer la signature mail.
J'ai le code ci-dessous, je ne suis pas loin du but, mais pour le moment, cela s'affiche dans le désordre.
Pouvez-vous m'aider svp ?
Merci.
JL
Code:
Sub Mail()
Dim tab_synthèse As Range
Dim liste_destinataires1 As String
Dim liste_cc1 As String
Dim OutlookApp1 As Object
Dim NewMail1 As Object
Dim tab1 As Object
Dim wDoc As Object
ActiveWorkbook.Save
DateDuJour = Format(Date, "dd mmmm yyyy")
Heure = Format(Time, "hh:nn")
'''''''''''''''''''''''''''''''''''''
' Liste de diffusion '
'''''''''''''''''''''''''''''''''''''
nb_contacts1 = Worksheets("Notice").Cells(Rows.Count, "Q").End(xlUp).Row
nb_contacts_copie1 = Worksheets("Notice").Cells(Rows.Count, "T").End(xlUp).Row
For i = 2 To nb_contacts1
liste_destinataires1 = liste_destinataires1 & Worksheets("Notice").Range("Q" & i) & ";"
Next i
For i = 2 To nb_contacts_copie1
liste_cc1 = liste_cc1 & Worksheets("Notice").Range("T" & i) & ";"
Next i
'''''''''''''''''''''''''''''''''''
' Préparation mail '
'''''''''''''''''''''''''''''''''''
Set OutlookApp1 = CreateObject("Outlook.Application") 'ouverture d'Outlook
Set NewMail1 = OutlookApp1.CreateItem(0) 'ouverture d'un nouveau mail
With NewMail1
.Display 'déclare la signature du mail
.To = liste_destinataires1 'écrit la liste de destinataires
.CC = liste_cc1 'écrit la liste des personnes en copie
.Subject = "Mail | " & DateDuJour & " | " & Heure 'écrit l'objet du mail
Set wDoc = NewMail1.GetInspector.WordEditor
ActiveSheet.Range("R5", ActiveSheet.Range("a65536").End(xlUp)).CopyPicture
wDoc.Application.Selection.Paste
Set rng = wDoc.Content
rng.InsertBefore "Bonjour" & vbNewLine & vbNewLine & "Voici le résultat :" & vbNewLine
rng.InsertAfter vbNewLine & vbNewLine & "Merci" & vbNewLine
.Display
End With
End Sub