1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
| Sub Test()
HTML = "<Html><Head></Head><Body>[MONTEXTE][InertTableau]</Body></Html>"
MONTEXTE = "Dear,<br>Please find below the invoices to do for this week.<br>Remember to update the operation files to not receive this reminder.<br>Have a Good Day.<br>"
HTML = Replace(HTML, "[MONTEXTE]", MONTEXTE)
HTML = Replace(HTML, "[InertTableau]", RetournTable(Worksheets("Recap").Range("A10:J14")))
Mail "Sujet", HTML , "Destinataire@gmail.com"
end sub
Sub Mail(Sujet As String, Message As String, Destinataire As String, Optional DestinataireCopy As String, Optional DestinataireCopyCacher As String, Optional Pj As String = "")
Set objOutlook = CreateObject("Outlook.application")
Set MailObj = objOutlook.CreateItem(olMailItem)
With MailObj
.To = Destinataire
.CC = DestinataireCopy
.BCC = DestinataireCopyCacher
.Subject = Sujet
.BodyFormat = 2
.HTMLBody = Message
If Trim("" & Pj) <> "" Then
p = Split(Pj & ";", ";")
For i = 0 To UBound(p)
If Trim("" & p(i)) <> "" Then .Attachments.Add Trim("" & p(i))
Next
End If
'.Display 'Can be .Send but prompts for user intervention before sending without 3rd party software like ClickYes
.Send
End With
End Sub
Function RetournTable(R As Range) As String
Dim L As Integer, C As Integer, Styl As String, elem As Object
For L = 1 To R.Rows.Count
code = code & "<tr id=ligne" & L & " > " & vbCrLf
For C = 1 To R.Columns.Count
code = code & "<td id=" & R(L, C).Address & ">" & R(L, C).Value & "</td>" & vbCrLf
Next
code = code & "</tr>" & vbCrLf
Next
With CreateObject("htmlfile")
.write "<table>" & vbCrLf & code & "</table>"
'ON VA STYLER LES CELLULES HTML IDENTIQUEMENT A CELLE DU SHEETS
For Each elem In .all
If elem.TAGNAME = "TABLE" Then
elem.cellspacing = 0: elem.Style.Width = R.Width * (96 / 72): elem.Style.Height = R.Height * (96 / 72): elem.Style.bordercollapse = "collapse"
End If
If elem.TAGNAME = "TD" Then
elem.Style.Border = "1px solid " & coul_XL_to_coul_HTMLX(15853019)
elem.Style.backgroundcolor = coul_XL_to_coul_HTMLX(Range(elem.ID).Interior.Color)
elem.Style.Color = coul_XL_to_coul_HTMLX(Range(elem.ID).Font.Color)
elem.Style.fontWeight = IIf(Range(elem.ID).Font.Bold, "bold", "")
elem.Style.FontStyle = IIf(Range(elem.ID).Font.Italic, "italic", "")
elem.Style.Width = Range(elem.ID).Width * (96 / 72)
elem.Style.Height = Range(elem.ID).Height * (96 / 72)
End If
Next
RetournTable = "<Div align='center'>" & .body.innerhtml & "</Div>"
End With
End Function
Function coul_XL_to_coul_HTMLX(couleur)
Dim str0 As String, str As String
If couleur = 16777215 Then couleur = vbWhite
str0 = Right("000000" & Hex(couleur), 6)
str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
coul_XL_to_coul_HTMLX = "#" & str & ""
End Function |
