'-------------------------------------
'patricktoulon
'date: 03/06/2021
'outlook en late binding
'PAS DE REFERENCE A ACTIVER
'-------------------------------------
Option Explicit
Sub test4()
Dim oApp As Object, oEmail As Object, colAttach As Object, oAttach As Object, plage As Range, olkPA As Object
Dim Destinataire$, CC$, Titre$, NomPdf$, NomImage$, imG$, paragraph1$, paragraph2$, xHTMLBody$
Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set plage = Feuil1.[A1:c10] ' plage à envoyer dans le corps du mail
NomImage = ThisWorkbook.Path & "\imgTemp.gif": If Dir(NomImage) <> "" Then Kill (NomImage) ' ne pas toucher ça
NomPdf = ThisWorkbook.Path & "\pdfTemp.pdf": If Dir(NomPdf) <> "" Then Kill (NomPdf) ' adapter le chemin du fichier pdf
'------------------------------
'exportation des fichiers temporaires
'création du pdf avec la plage
plage.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomPdf, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'creation de la capture de la plage en image
imG = ExportRangeInImage(plage, NomImage)
If imG = "" Then MsgBox "la copie de la plage en image n'a pas pu etre effectué": Exit Sub
'----------------------------
'élements du mail
Titre = "test de mail outlook VBA shema late binding" 'titre du message
Destinataire = "toto@hotmail.fr" 'destinataire(s) du message( si plusieurs séparer les par une virgule)
CC = "" ' accusé reception
'texte que tu veux avant la plage dans le mail(facultatif)
paragraph1 = "envoyé à " & Time & vbCrLf & "Bonjour Mr le directeur " & vbCrLf & "veuillez trouver ci joint le tableau des ventes de concombres"
paragraph1 = paragraph1 & vbCrLf & " il resume les ventes du mois "
'texte que tu veux apres la plage dans le mail(facultatif)
paragraph2 = " vous souhaitant bonne réception" & vbCrLf & "restant a votre disposition pour tout renseignement"
paragraph2 = paragraph2 & vbCrLf & " votre dévoué serviteur <font face=algerian color=red>le Concombre masqué</font>"
'création du code html du body apec les paragraphes et l'image de la plage
xHTMLBody = "<BODY>" & Replace(paragraph1, vbCrLf, "<br>") & "<br><br>" & _
"<center><img src=""cid:imgTemp.gif""></center><br><br>" & _
Replace(paragraph2, vbCrLf, "<br>")
xHTMLBody = xHTMLBody & "</BODY>"
'----------------------------
''création du mail
Set oApp = CreateObject("Outlook.Application") 'instance outlook
Set oEmail = oApp.CreateItem(olMailItem) 'instance de l'item mail dans outlook
Set colAttach = oEmail.Attachments ' ça c'est la collection des attachements
'----------------------------------------------------------------------
' a répéter pour chaque image placées dans le body!!!!!!!!!!!
'on attache l'image
Set oAttach = colAttach.Add(NomImage) 'on ajoute dans la collection d'attachements l'image de la plage
Set olkPA = oAttach.PropertyAccessor 'collection des properties d'accessibilité de l'attachement
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "imgTemp.gif" '' application de la propriété cid a l'attachement
'----------------------------------------------------------------------
oEmail.HTMLBody = xHTMLBody ' insertion du code html dans le body du mail
oEmail.To = Destinataire
oEmail.Subject = Titre
oEmail.CC = CC ' accusé
oEmail.Attachments.Add NomPdf ' on attache le pdf de façon classique
'oEmail.Display
oEmail.Send
' vide les variable
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
Private Function ExportRangeInImage(plage As Range, CheminX As String)
'export plage en gif patricktoulon sur exceldownloads
Dim chart1 As Object
If Dir(CheminX) <> "" Then Kill CheminX
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With 'on vide le clipboard entre chaque copie pour tester vraiment le available
plage.CopyPicture
Set chart1 = plage.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
With chart1
With .Parent: .Width = plage.Width: .Height = plage.Height: .Left = plage.Width + 20:
.Parent.Shapes(.Name).Line.Visible = False
Do: .Chart.Paste: DoEvents: Loop While .Chart.Pictures.Count = 0
.Chart.Export CheminX, "gif"
End With
.Parent.Delete
End With
ExportRangeInImage = Dir(CheminX)
End Function