Function pPx()
With ActiveWindow
pPx = 1 / ((.PointsToScreenPixelsX(7200) - .PointsToScreenPixelsX(0)) / 7200)
End With
End Function
Function CreatehtmlTable(rng As Range, Optional GridLine As Boolean = False, Optional CssOutLine As Boolean = False, Optional Col_1_Stiky As Boolean = False, Optional Row_1_Stiky As Boolean = False)
Dim DhtmL As Object, dico As Object, dicoId As Object, Table, TbodY, cel, lig, col, crit, TR, TD, Tds, bw, bws, bwt, bwts, bwr, bwrs, bbwr, bbwrs, classe, css, elem, IdX, w
If CssOutLine Then Set dico = CreateObject("Scripting.Dictionary")
Set DhtmL = CreateObject("htmlfile")
Set dicoId = CreateObject("scripting.dictionary")
DhtmL.body.innerHTML = "<table><TBODY></TBODY></table>"
Set Table = DhtmL.getElementsByTagName("table")(0)
Table.className = "table" & Format(Now, "yyyymmddhhnnss")
Set TbodY = DhtmL.getElementsByTagName("TBODY")(0)
For lig = 1 To rng.Rows.Count
'If Application.WorksheetFunction.CountA(rng.Cells(lig, 1).Resize(1, rng.Columns.Count)) > 0 Then
Set TR = TbodY.appendChild(DhtmL.createElement("TR"))
For col = 1 To rng.Columns.Count
Set cel = rng.Cells(lig, col).MergeArea
IdX = cel.Address(0, 0)
If Not dicoId.exists(IdX) Then
'If DhtmL.getElementById(IdX) Is Nothing Then
Set TD = TR.appendChild(DhtmL.createElement("TD"))
TD.setAttribute "id", IdX
dicoId(IdX) = ""
TD.colSpan = cel.Columns.Count
TD.rowSpan = cel.Rows.Count
If cel.Cells(1).Value <> "" Then
With cel.Cells(1): crit = IsNull(.Font.Color) Or IsNull(.Font.Bold) Or IsNull(.Font.Italic): End With
If crit Then
TD.innerHTML = htmltexte(cel.Cells(1))
Else
TD.innerHTML = cel.Cells(1).Text
If cel.Font.Bold = True Then TD.innerHTML = "<B>" & TD.innerHTML & "</B>"
If cel.Font.Italic = True Then TD.innerHTML = "<i>" & TD.innerHTML & "</i>"
If cel.Font.Color <> vbBlack Then TD.innerHTML = "<font color=" & coul_XL_to_coul_HTMLX(cel.DisplayFormat.Font.Color) & " >" & TD.innerHTML & "</font>"
End If
If cel.Hyperlinks.Count > 0 Then
TD.innerHTML = ""
Set bal_A = TD.appendChild(DhtmL.createElement("a"))
bal_A.setAttribute "href", cel.Hyperlinks(1).Address
bal_A.innerHTML = cel.Text
End If
End If
With TD.style
If lig = 2 Then w = w + Round((cel.width + 1) / 0.75)
.width = Round((cel.width + 1) / pPx) & "px"
.Height = Round((cel.Height + 1) / pPx) & "px"
.backgroundColor = coul_XL_to_coul_HTMLX(cel.DisplayFormat.Interior.Color)
Set bw = cel.Borders(xlEdgeLeft)
If cel.Borders(xlEdgeLeft).LineStyle <> xlNone Then
bws = bw.LineStyle
.borderLeftWidth = Switch(bw.Weight = xlThick, "3px", bw.Weight = xlMedium, "2px", bw.Weight = xlThin, "1px", bw.Weight = xlHairline, "0.5pt")
.borderLeftColor = coul_XL_to_coul_HTMLX(cel.Borders(xlEdgeLeft).Color)
.borderLeftStyle = Switch(bws = xlContinuous, "solid", bws = xlDash, "dashed", bws = xlDot, "dotted", bws = xlDashDot, "dashed", bws = xlDashDotDot, "dotted", bws = xlDouble, "double", bws = xlSlantDashDot, "dashed")
Else
If GridLine Then
.borderLeftWidth = "0.5pt"
.borderLeftColor = coul_XL_to_coul_HTMLX(RGB(230, 230, 230))
.borderLeftStyle = "solid"
End If
End If
Set bwt = cel.Borders(xlEdgeTop)
If cel.Borders(xlEdgeTop).LineStyle <> xlNone Then
bwts = bwt.LineStyle
.borderTopWidth = Switch(bwt.Weight = xlThick, "3px", bwt.Weight = xlMedium, "2px", bwt.Weight = xlThin, "1px", bwt.Weight = xlHairline, "0.5pt")
.borderTopColor = coul_XL_to_coul_HTMLX(cel.Borders(xlEdgeTop).Color)
If cel.DisplayFormat.Interior.Color = vbBlack Then .borderTopColor = coul_XL_to_coul_HTMLX(RGB(230, 230, 230))
.borderTopStyle = Switch(bwts = xlContinuous, "solid", bwts = xlDash, "dashed", bwts = xlDot, "dotted", bwts = xlDashDot, "dashed", bwts = xlDashDotDot, "dotted", bwts = xlDouble, "double", bwts = xlSlantDashDot, "dashed")
.textAlign = "center"
Else
If GridLine Then
.borderTopWidth = "0.5pt"
.borderTopColor = coul_XL_to_coul_HTMLX(RGB(230, 230, 230))
.borderTopStyle = "solid"
End If
End If
If col = rng.Columns.Count Then
Set bwr = cel.Borders(xlEdgeRight)
If cel.Borders(xlEdgeRight).LineStyle <> xlNone Then
bwrs = bwr.LineStyle
.borderRightWidth = Switch(bwr.Weight = xlThick, "3px", bwr.Weight = xlMedium, "2px", bwr.Weight = xlThin, "1px", bwr.Weight = xlHairline, "0.5pt")
.borderRightColor = coul_XL_to_coul_HTMLX(cel.Borders(xlEdgeRight).Color)
.borderRightStyle = Switch(bwrs = xlContinuous, "solid", bwrs = xlDash, "dashed", bwrs = xlDot, "dotted", bwrs = xlDashDot, "dashed", bwrs = xlDashDotDot, "dotted", bwrs = xlDouble, "double", bwrs = xlSlantDashDot, "dashed")
Else
If GridLine Then
End If
.borderRightWidth = "0.5pt"
.borderRightColor = coul_XL_to_coul_HTMLX(RGB(230, 230, 230))
.borderRightStyle = "solid"
End If
End If
If lig = rng.Rows.Count Then
Set bbwr = cel.Borders(xlEdgeBottom)
If cel.Borders(xlEdgeBottom).LineStyle <> xlNone Then
bbwrs = bbwr.LineStyle
.borderBottomWidth = Switch(bbwr.Weight = xlThick, "3px", bbwr.Weight = xlMedium, "2px", bbwr.Weight = xlThin, "1px", bbwr.Weight = xlHairline, "0.5pt")
.borderBottomColor = coul_XL_to_coul_HTMLX(cel.Borders(xlEdgeBottom).Color)
.borderBottomStyle = Switch(bbwrs = xlContinuous, "solid", bbwrs = xlDash, "dashed", bbwrs = xlDot, "dotted", bbwrs = xlDashDot, "dashed", bbwrs = xlDashDotDot, "dotted", bbwrs = xlDouble, "double", bbwrs = xlSlantDashDot, "dashed")
Else
If GridLine Then
.borderBottomWidth = "0.5pt"
.borderBottomColor = coul_XL_to_coul_HTMLX(RGB(230, 230, 230))
.borderBottomStyle = "solid"
End If
End If
End If
'--------------------------------------------------------------------------------
'alignement des valeurs dans la cellulehtml idem aux cellules excel
Al = cel.HorizontalAlignment 'l'alignement horizontal du texte pour la cellule
AlR = rng.Rows(lig).HorizontalAlignment 'l'alignement horizontal du texte pour la ligne complète
Al = Switch(Al = xlLeft, "left", Al = xlCenter, "center", Al = xlRight, "right")
AlR = Switch(AlR = xlLeft, "left", AlR = xlCenter, "center", AlR = xlRight, "right")
If Not IsNull(AlR) Then
TR.style.textAlign = AlR
Else
If Not IsNull(Al) Then .textAlign = Al Else .textAlign = "left"
End If
ValV = cel.VerticalAlignment 'l'alignement vertical du texte pour la cellule
VaLR = rng.Rows(lig).VerticalAlignment 'l'alignement vertical du texte pour la ligne complète
ValV = Switch(ValV = xlTop, "top", ValV = xlCenter, "middle", ValV = xlBottom, "bottom")
VaLR = Switch(VaLR = xlTop, "top", VaLR = xlCenter, "middle", VaLR = xlBottom, "bottom")
If Not IsNull(VaLR) Then
TR.vAlign = VaLR
Else
If Not IsNull(ValV) Then .verticalAlign = ValV Else .verticalAlign = "bottom"
End If
'------------------------------------------------------------------------------
End With
End If
'on sort le CSS du htmlSI cSSiNLINE+FALSE
If CssOutLine Then
If Not dico.exists("{" & TD.style.cssText & ";}") Then
classe = "cla" & dico.Count
dico("{" & TD.style.cssText & ";}") = classe
TD.className = classe
Else
TD.className = dico("{" & TD.style.cssText & ";}")
End If
TD.removeAttribute ("style")
End If
Next
'End If
Next
If CssOutLine Then
css = "<style>" & vbCrLf
For Each elem In dico
css = css & vbCrLf & "." & dico(elem) & elem & vbCrLf
Next
'le css pour figer la colonne mode "stiky"pour les premier TD de chaque TR
If Col_1_Stiky Then
css = css & "tr td:first-child,tr th:first-child { position: sticky; left: 0; z-index: 5;border-rigth:2px double red;}" & vbCrLf
Set TRs = DhtmL.getElementsByTagName("TR")
Dim i&
For i = 0 To TRs.Length - 1
TRs(i).FirstChild.style.backgroundColor = coul_XL_to_coul_HTMLX(rng.Cells(i + 1, 1).DisplayFormat.Interior.Color)
TRs(i).FirstChild.style.borderRight = "3px double red"
Next
End If
If Row_1_Stiky Then
css = css & "tr:first-child td {position: sticky;top: 0; z-index: 6;}" & vbCrLf
Set Tds = DhtmL.getElementsByTagName("TR")(0).getElementsByTagName("TD")
Dim c&
For c = 0 To Tds.Length - 1
Tds(c).style.backgroundColor = coul_XL_to_coul_HTMLX(rng.Cells(1, c + 1).DisplayFormat.Interior.Color)
Tds(c).style.borderBottom = "3px double red"
Next
End If
End If
With Table.style
'.borderCollapse = "collapse"
.width = Int(w) + 1 & "px"
.borderCollapse = "separate"
.borderSpacing = "0"
End With
If CssOutLine Then
css = css & "." & Table.className & "{" & Table.style.cssText & ";}" & vbCrLf
Table.removeAttribute ("style")
End If
css = css & "</style>" & vbCrLf
If CssOutLine Then
CreatehtmlTable = Array(css, Table.outerHTML)
Else
CreatehtmlTable = Table.outerHTML
End If
End Function
Function coul_XL_to_coul_HTMLX(couleur)
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
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
Function htmltexte(cel As Range)
'Fonction de récupération du code html du texte formaté dans la cellule
'Patricktoulon (2016)
Dim cde$, elem, Dc As New HTMLDocument
cde = Replace(Replace(Replace(cel.Value(11), "ss:", ""), "Data", "Div"), "html:", "")
cde = Replace(cde, " ", vbCrLf)
With Dc
.body.innerHTML = cde
Debug.Print .body.innerHTML
For Each elem In .all
If elem.getAttribute("size") <> "" Then elem.style.FontSize = elem.getAttribute("size") & "pt"
elem.removeAttribute ("size")
Next
htmltexte = .getElementsByTagName("Div")(0).innerHTML
End With
End Function
