Option Explicit
Sub EnvoyerTCDparMail2()
Dim TCD As Range, MailApp As Object, Mail As Object, Ws As Worksheet, Destinataire$, Fichier$, CorpsMail$, chemin$
chemin = ThisWorkbook.Path & "\tcd.png"
Set Ws = ActiveSheet
Set TCD = Ws.PivotTables("tcd1").TableRange2
If TCD Is Nothing Then
MsgBox "Le tableau croisŽ dynamique 'tableau croisŽ 1' n'existe pas sur la feuille active.", vbExclamation
Exit Sub
End If
Fichier = CopyOBJECTInImagePNG(TCD, chemin, True) 'on copie le tableau en png
CorpsMail = "<html><body style=""font-family:calibri;font-size:11pt;""><p>Bonjour,</p><p>Voici l'état des commandes en retard d'expédition.</p><br>Cordialement.<br>"
' l'image du tableau
CorpsMail = CorpsMail & "<img src=""tcd.png"" style=""width:" & Round(TCD.Width * 1.15) & "pt;height:" & Round(TCD.Height * 1.15) & "pt;""></img><br><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 = Destinataire
Mail.Cc = Destinataire
Mail.attachments.Add Fichier
Mail.Display
'Mail.send
Set Mail = Nothing
Set MailApp = Nothing
Set Ws = Nothing
Set TCD = Nothing
Kill Fichier
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
'**********************************************************************************
' __ _____ ___ . ___ _____ ___ ___
'|__| /\ | | | | | | / | | | | | | | | |\ |
'| /__\ | |--- | | |/\ | | | | | | | | | \ |
'| / \ | | \ | |___ | \ | |___| |___| |__ |___| | \|
'
'***********************************************************************************
' COLLECTION IMAGE ET SHAPES
'exporter un object en PNG(range,shapes et tout autre object present sur la feuille)
'version avec graphique 1.3(PNG)
'date version 03/05/2016
'mise à jour:15/07/2018
'suppression de la gestion d'attente par l'api IsClipboardFormatAvailable
'remplacer par un multiple paste dans le chart tant que son pictures.count=0(Idée de @Job75)
'l'area du graph est visible ,solid et transparent à 100%
'ce qui implique que la capture peut garder ses parties transparentes (argument <<Notransparency>>)
'**********************************************************************************
'ici en l'occurence on restera en fond blanc
Function CopyOBJECTInImagePNG(ObjecOrRange, _
Optional cheminx As String = "", _
Optional Notransparency As Boolean = False) As String
Dim Graph As Object, CheminT$
If cheminx = "" Then cheminx = ThisWorkbook.Path & "\imagetemp.png"
CheminT = cheminx
With CreateObject("htmlfile").parentwindow.clipboardData.clearData("Text"): End With 'on vide le clipboard entre chaque copie pour tester vraiment le available
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