Option Explicit
Sub EnvoyerTCDparMail2()
Dim TCD(1 To 3) As Range, MailApp As Object, Mail As Object, Ws As Worksheet, Destinataire$, Fichier$, CorpsMail$, chemin$(1 To 3), i&, texte
chemin(1) = ThisWorkbook.Path & "\tcd1.png"
chemin(2) = ThisWorkbook.Path & "\tcd2.png"
chemin(3) = ThisWorkbook.Path & "\tcd3.png"
Set Ws = ActiveSheet
On Error Resume Next
Set TCD(1) = Ws.PivotTables("tcd1").TableRange2
Err.Clear
Set TCD(2) = Ws.PivotTables("tcd2").TableRange2
Err.Clear
Set TCD(3) = Ws.PivotTables("tcd3").TableRange2
On Error GoTo 0
For i = 1 To 3
If TCD(i) Is Nothing Then
texte = texte & "Le tableau croisŽ dynamique TCD" & i & " n'existe pas sur la feuille active." & vbCrLf
End If
Next
If texte <> "" Then MsgBox texte, vbExclamation
For i = 1 To 3
If Not TCD(i) Is Nothing Then Fichier = CopyOBJECTInImagePNG(TCD(i), chemin(i), True) 'on copie le tableau en png
Next
CorpsMail = "<html><body style=""font-family:calibri;font-size:11pt;"">" & Replace(Feuil1.[G3].Text, Chr(10), "<br>") & "<br><br>"
' l'image du tcd1
If Not TCD(1) Is Nothing Then CorpsMail = CorpsMail & "<img src=""tcd1.png"" style=""width:" & Round(TCD(1).Width) & "pt;height:" & Round(TCD(1).Height) & "pt;""></img><br><br>"
' l'image du tcd2
If Not TCD(2) Is Nothing Then CorpsMail = CorpsMail & "<img src=""tcd2.png"" style=""width:" & Round(TCD(2).Width) & "pt;height:" & Round(TCD(2).Height) & "pt;""></img><br><br>"
' l'image du tcd3
If Not TCD(3) Is Nothing Then CorpsMail = CorpsMail & "<img src=""tcd3.png"" style=""width:" & Round(TCD(3).Width) & "pt;height:" & Round(TCD(3).Height) & "pt;""></img><br><br>"
CorpsMail = CorpsMail & "<br>Cordialement.<br>"
'la signature
CorpsMail = CorpsMail & GetCodeSig("blablabla") 'adapter le nom de la signature
'fermeture du body
CorpsMail = CorpsMail & "</body></html>"
Set MailApp = CreateObject("Outlook.Application")
Set Mail = MailApp.CreateItem(0)
Mail.Subject = "Commandes en retard d'expédition"
Mail.htmlbody = CorpsMail
Mail.To = Feuil1.[G1].Text
Mail.Cc = Feuil1.[G2].Text
For i = 1 To 3
If Dir(chemin(i)) <> "" Then Mail.attachments.Add ThisWorkbook.Path & "\tcd" & i & ".png"
Next
Mail.Display
'Mail.send
Set Mail = Nothing
Set MailApp = Nothing
Set Ws = Nothing
For i = 1 To 3: Set TCD(i) = Nothing: Next
For i = 1 To 3
If Dir(chemin(i)) <> "" Then Kill chemin(i)
Next
End Sub
Function GetCodeSig(ByVal Signature As String) As String
Dim x%, lines$, i&, Fichier$: x = FreeFile
Fichier = Environ("appdata") & "\Microsoft\Signatures\" & Signature & ".htm"
If Dir(Fichier) = "" Then Exit Function
Open Fichier For Input As #x: lines = Input$(LOF(x), #x): Close #x
GetCodeSig = lines
End Function
Function CopyOBJECTInImagePNG(ObjecOrRange, _
Optional cheminx As String = "", _
Optional Notransparency As Boolean = False) As String
'Autor:patricktoulon
'https://excel-downloads.com/resources/une-fonction-pour-capturer-un-object-dans-une-feuille-en-png-avec-un-graphique-qui-marche-vraiment.1469/
Dim Graph As Object, CheminT$
If cheminx = "" Then cheminx = ThisWorkbook.Path & "\imagetemp.png"
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With 'on vide le clipboard entre chaque copie pour tester vraiment le available
DoEvents
ObjecOrRange.CopyPicture Format:=IIf(Notransparency, xlBitmap, xlPicture)
Set Graph = ObjecOrRange.Parent.ChartObjects.Add(0, 0, 0, 0).Chart
ActiveSheet.Shapes(Graph.Parent.Name).Line.Visible = msoFalse
With Graph.Parent
.Width = ObjecOrRange.Width: .Height = ObjecOrRange.Height: .Left = ObjecOrRange.Width + 20:
.Select
Do: DoEvents
.Chart.Paste
Loop While .Chart.Pictures.Count = 0
.Chart.ChartArea.Fill.Visible = msoTrue
.Chart.ChartArea.Fill.Solid
.Chart.ChartArea.Format.Fill.Transparency = 1
.Chart.Export cheminx, "png"
End With
Graph.Parent.Delete
CopyOBJECTInImagePNG = cheminx
End Function
) , prendre les valeurs dans les cellules :
