Sub sendMail()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
On Error Resume Next
Set xRg = Range("A3:E10")
If xRg Is Nothing Then Exit Sub
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("Public") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Bonjour, <br><br>" _
& "Ci-joint les retours <br> " _
& "<br>"
' corps = "<body><p><font face=arial><FONT COLOR=MEDIUMBLUE>Liste des Avis mal renseignés: <BR><BR>"
'Debug.Print CréateHTMLTABLE(xRg) 'juste pour voir un vrai code de table html dans la console
xHTMLBody = xHTMLBody & CréateHTMLTABLE(xRg) & "<br><br>"
With xOutMail
.Subject = "Demande de retour pour le mois...... - "
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = " "
.Cc = " "
.Display
End With
Kill "C:\Users\Public\Dashboardfile.jpg"
End Sub
Function CréateHTMLTABLE(plage As Range) As String
'Fonction range to table html ----> By patricktoulon
Dim tbl, Addr$, I&, j&, cel As Range, TD, TR, Table, TA, Tal, VA, VraL, Texte
With CreateObject("htmlfile")
Set Table = .createelement("table"): .body.appendchild (Table)
With Table.Style
.bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri"
.Width = Round(plage.Width) + 1 & "pt"
End With
For I = 1 To plage.Rows.Count
Set TR = .createelement("TR"): Table.appendchild (TR)
For j = 1 To plage.Columns.Count
Set cel = plage.Cells(I, j).MergeArea: Addr = cel.Address
If .getelementbyid(Addr) Is Nothing Then
Set TD = .createelement("TD"): TD.ID = Addr: TD.colspan = cel.Columns.Count: TD.rowspan = cel.Rows.Count
Texte = IIf(cel.Font.Bold, "<B>" & cel.Text & "</B>", cel.Text)
Texte = IIf(cel.Font.Italic, "<EM>" & Texte & "</EM>", Texte)
Texte = IIf(cel.Font.Underline > 0, "<u>" & Texte & "</u>", Texte)
TD.innerhtml = Texte
'If cel(1).Font.Bold = True Then MsgBox "oui": TD.innerhtml "<B>" & TD.innertext & "</B>"
'If cel(1).Font.Italic Then TD.innerhtml "<i>" & TD.innerhtml & "</i>"
With TD.Style
.margin = "2pt": .Border = "0.5pt solid #000000"
.Width = Round(cel.Width) & "pt": .Height = Round(cel.Height) & "pt"
If Range(Addr).WrapText Then .WORDBREAK = "break-all"
If Val(cel.Font.Color) <> 0 Then .Color = coul_XL_to_coul_HTMLX(Val(cel.Font.Color))
If Val(cel.Interior.Color) <> 0 Then .backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)
If cel(1).Font.Name <> "calibri" Then .fontfamily = cel(1).Font.Name
If cel(1).Font.Size <> 11 Then .FontSize = cel(1).Font.Size & "pt"
'alignement
TA = cel.HorizontalAlignment: Tal = Switch(TA = xlLeft, "left", TA = xlCenter, "center", TA = xlRight, "right", TA = xlGeneral, "left", IsDate(cel.Value) And TA = xlGeneral, "right")
VA = cel.VerticalAlignment: VraL = Switch(VA = xlTop, "top", VA = xlCenter, "middle", VA = xlBottom, "bottom", VA = xlGeneral, "bottom")
If IsDate(cel.Value) And TA = xlGeneral Then Tal = "right"
.TextAlign = Tal
.verticalalign = VraL
End With
TR.appendchild (TD)
End If
Next
Next
End With
CréateHTMLTABLE = Table.outerhtml
End Function
Function coul_XL_to_coul_HTMLX(couleur)
'fonction HTMLCOLOR ---> By Patricktoulon
Dim str0 As String, strf As String
str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
coul_XL_to_coul_HTMLX = "#" & strf & ""
End Function
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
Dim xShape As Shape
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
For Each xShape In ActiveSheet.Shapes
xShape.Line.Visible = msoFalse
Next
' ajout du delay d'attente clipboard methode @job75
Do While .Chart.Pictures.Count = 0
.Chart.Paste
Loop
.Chart.Export Environ$("Public") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub
