'****************************************************************************************************
Function PutShapOnHtmlOutlook(CdeHTML$, Rng As Range, Optional ByVal DossierImage$ = "")
'Function d'ajout des emmbeds image dans le code html d'une cellule TD html en utilisant 2 balises "PRE"
'retransformé en en code shape:VML pour outlook
'patricktoulon (2022)
Dim DcO As New HTMLDocument, shap As Object, cel As Range, TD, VrecT, VfilL, addr$, dossier
Dim pres, A&, bal$, deb$, fin$, code$, ImG, Li
DcO.body.innerhtml = CdeHTML
For Each shap In Rng.Parent.DrawingObjects
Set cel = shap.TopLeftCell.MergeArea
addr = cel.Address(0, 0)
If Not Intersect(shap.TopLeftCell, Rng) Is Nothing Then
Set TD = DcO.getelementbyid(addr)
Set TD = DcO.getelementbyid(addr): TD.Style.Position = "relative"
TD.Style.Position = "relative"
Set Li = DcO.createElement("LI")
Set ImG = DcO.createElement("IMG")
Li.appendchild (ImG)
Set VrecT = DcO.createElement("pre")
VrecT.setattribute "xmlns:v", "urn:schemas-microsoft-com:vml"
VrecT.setattribute "fill", "true"
VrecT.setattribute "stroke", "false"
VrecT.setattribute "bal", "v:rect"
With VrecT.Style
.Position = "absolute"
.Left = Int(Int(shap.Left) - cel.Left - 1) & "pt"
.Top = Replace(shap.Top - cel.Top - 1, ",", ".") & "pt"
.Width = Replace(shap.Width * 1.04, ",", ".") & "pt"
.Height = Replace((shap.Height) * 1.2, ",", ".") & "pt"
End With
TD.appendchild (VrecT)
With ImG.Style
.Position = "absolute"
.Left = Int(Int(shap.Left) - cel.Left - 1) & "pt"
.Top = Replace(shap.Top - cel.Top, ",", ".") & "pt"
.Width = Replace(shap.Width * 1.07, ",", ".") & "pt"
.Height = Replace((shap.Height) * 1.1, ",", ".") & "pt"
.zIndex = 1
End With
A = A + 1
ImG.src = Mid(DossierImage, InStrRev(DossierImage, "\") + 1) & "\" & "image" & A & ".png" ' Replace(shap.Name, " ", "_") & ".png"
Set VfilL = DcO.createElement("pre")
VfilL.setattribute "type", "frame"
VfilL.setattribute "bal", "v:fill"
VfilL.setattribute "src", "image" & A & ".png" ' Replace(shap.Name, " ", "_") & ".png"
VrecT.appendchild (VfilL)
TD.appendchild (Li)
End If
Next
Set pres = DcO.getelementsbytagname("PRE")
For A = pres.Length - 1 To 0 Step -1
bal = pres(A).getattribute("bal")
If InStr(pres(A).outerhtml, "<pre") > 0 Then
pres(A).outerhtml = Replace(Replace(pres(A).outerhtml, "<pre", "<" & bal), "pre>", vbCrLf & bal & ">")
Else
pres(A).outerhtml = Replace(Replace(pres(A).outerhtml, "<PRE", "<" & bal), "PRE>", vbCrLf & bal & ">")
End If
Next
deb = "<!--[if mso]>": fin = "<![endif]-->"
code = DcO.body.innerhtml
code = Replace(code, "</ v:rect>", "")
code = Replace(code, "</ v:fill>", "")
code = Replace(code, "<v:rect", vbCrLf & deb & vbCrLf & "<v:rect")
code = Replace(code, "</v:rect>", "</v:rect>" & vbCrLf & fin)
code = Replace(code, "</v:fill>", vbCrLf & "</v:fill>")
code = Replace(code, "<?xml:namespace prefix = v />", "")
code = Replace(code, "bal=""v:rect""", "")
code = Replace(code, "bal=""v:fill""", "")
If InStr(1, code, "<li>") > 1 Then
code = Replace(code, "<li>", "<!--[if !mso]><!-- -->" & vbCrLf)
code = Replace(code, "</li>", vbCrLf & "<!--<![endif]-->" & vbCrLf)
Else
code = Replace(code, "<LI>", "<!--[if !mso]><!-- -->" & vbCrLf)
code = Replace(code, "</LI>", vbCrLf & "<!--<![endif]-->" & vbCrLf)
End If
PutShapOnHtmlOutlook = code
Set DcO = Nothing
End Function
