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]
NomImage = ThisWorkbook.Path & "\imgTemp.gif": If Dir(NomImage) <> "" Then Kill (NomImage)
NomPdf = ThisWorkbook.Path & "\pdfTemp.pdf": If Dir(NomPdf) <> "" Then Kill (NomPdf)
plage.ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomPdf, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
imG = ExportRangeInImage(plage, NomImage)
If imG = "" Then MsgBox "la copie de la plage en image n'a pas pu etre effectué": Exit Sub
Titre = "test de mail outlook VBA shema late binding"
Destinataire = "toto2@outlook.fr"
CC = ""
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 "
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>"
xHTMLBody = "<BODY>" & Replace(paragraph1, vbCrLf, "<br>") & "<br><br>" & _
"<center><img src=""cid:imgTemp.gif""></center><br><br>" & _
Replace(paragraph2, vbCrLf, "<br>")
xHTMLBody = xHTMLBody & "</BODY>"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Set colAttach = oEmail.Attachments
Set oAttach = colAttach.Add(NomImage)
Set olkPA = oAttach.PropertyAccessor
olkPA.SetProperty PR_ATTACH_CONTENT_ID, "imgTemp.gif"
oEmail.HTMLBody = xHTMLBody
oEmail.To = Destinataire
oEmail.Subject = Titre
oEmail.CC = CC
oEmail.Attachments.Add NomPdf
oEmail.Display
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
Private Function ExportRangeInImage(plage As Range, CheminX As String)
Dim chart1 As Object
If Dir(CheminX) <> "" Then Kill CheminX
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With
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
