'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
' Collection Utilitaires VBA /HTM Range to html simplifié pour titof06
'Auteur patricktoulon
' cette fonction est issue et adaptée du module VBAhtml_GENERATOR de patricktoulon
Function CreatehtmlTable(rng As Range, Optional GridLine As Boolean = False, Optional CssOutLine As Boolean = False) As String
Dim dhtml As Object, dico As Object, Table, TbodY, cel, lig, col, crit, TR, TD, 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")
dhtml.body.innerHTML = "<table><TBODY></TBODY></table>"
Set Table = dhtml.getElementsByTagName("table")(0)
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 dhtml.getElementById(IdX) Is Nothing Then
Set TD = TR.appendChild(dhtml.createElement("TD"))
TD.setAttribute "id", 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
End If
End If
With TD.Style
If lig = 2 Then w = w + Round((cel.width + 1) / 0.75)
.width = Round((cel.width + 1) / 0.75) & "px"
.Height = Round((cel.Height + 1) / 0.75) & "px"
.backgroundColor = coul_XL_to_coul_HTMLX(cel.DisplayFormat.Interior.Color)
If Not IsNull(cel.Cells(1).Font.Color) And cel.Cells(1).Font.Color <> vbBlack Then .Color = coul_XL_to_coul_HTMLX(cel.Cells(1).Font.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)
.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
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 "fixed"pour les premier TD de chaque TR
'css = css & "td:first-child { position: fixed; left: 0; width: 83px; z-index: 10;border-right :2px double red;}/* IMPORTANT = largeur réelle */ " & vbCrLf
'css = css & "table { margin-left: " & Round(rng.Cells(1).width / 0.75) & "px;}" & vbCrLf
'----------------------------------------
'le css pour figer la colonne mode "fixed"pour les premier TD de chaque TR
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
css = css & "</style>" & vbCrLf
End If
With Table.Style
.borderCollapse = "collapse"
.width = Int(w) + 1 & "px"
End With
CreatehtmlTable = "<!DOCTYPE HTML><head>" & css & "</head><body>" & Table.outerHTML & "</body></html>"
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
