'*****************************************************************************************************
' ___ _ _______ __ _ ____ _ _ _______ ___ _ _ _ ___ _ _.
' // \\ /\\ // // \\ // // // // // // \\ // // // // \\ //| //
' //___// //__\ // //__// // // //__// // // // // // // // // // | //
' // // \\ // // \\ // // // \\ // // // // // // // // // | //
'// // // // // // // //___ // \\ // \\__// //__// //___ \\__// // |//
'****************************************************************************************************
' COLLECTION RANGE TO HTML
' ****************************************
' * fonction << ListObjectToTableHTML >> *
' ****************************************
'Auteur: patricktoulon
'Version 1.0
'Date version:05/02/2024
'C'est une fonction specialement et uniquement concu pour encoder un tableau structuré en html
'Elle vous renvoie donc un code HTML representant le tableau le plus fidèlement possible
'Elle peut être utilise pour envoyer un tableau structuré dans le corps du mail avec outlook
'Ou simplement enregistrer en fichier HTML
'Elle est issue de ma fonction range to html mais ultra simplifiée
'Je l'ai concu de telle maniere quu'elle en aLlège le code HTML résultant(même si ça rallonge un peu le code VBA)
'
'Un module de test simple est join avec pour que vous puissiez tester Outlook et enregistrer en fichier html
'Utilisation de ma fonction ConvertColorToHtmL de 2016 pour la conversion du code couleur(tout format Vers code coleur html)
'mise à jours
'Version 1.1
'date version:20/03/2024
'ajout de la reproduction des liens hypertext cliquables dans le html
'***************************************************************************************************
Option Explicit
Public Function ListObjectToTableHTML(tableau As ListObject)
Dim r As Range, HtmlDoC As Object, TD, TR, LiG&, C&, TableH, Fn$, FC, CelH, Al, VaL, Bal, ALR, VaLR, V$, bal_A
Fn = ThisWorkbook.Styles(1).Font.Name
FC = ThisWorkbook.Styles(1).Font.Color
Set r = tableau.Range
Set HtmlDoC = CreateObject("htmlfile")
HtmlDoC.body.innerhtml = "<table></table>"
Set TableH = HtmlDoC.getelementsbytagname("table")(0)
With TableH.Style
.bordercollapse = "collapse"
.fontfamily = Fn
.Color = ConvertColorToHtmL(FC)
.Width = Round(r.Width) & "pt"
.Height = Round(r.Height) & "pt"
.Border = "0.5pt solid " & ConvertColorToHtmL(RGB(230, 230, 230))
End With
For LiG = 1 To r.Rows.Count
Set TR = TableH.appendchild(HtmlDoC.createelement("tr"))
For C = 1 To r.Columns.Count
V = r.Cells(LiG, C).Text
If LiG = 1 Then
If Not tableau.HeaderRowRange Is Nothing Then Bal = "TH" Else Bal = "TD"
Else: Bal = "TD"
End If
Set CelH = TR.appendchild(HtmlDoC.createelement(Bal))
If r.Cells(LiG, C).Font.Italic Then V = "<i>" & V & "</i>"
If r.Cells(LiG, C).Font.Bold Then V = "<b>" & V & "</b>"
CelH.innerhtml = "<font>" & V & "</font>"
CelH.FirstChild.Style.margin = 0
If r.Cells(LiG, C).Hyperlinks.Count > 0 Then
CelH.FirstChild.innerhtml = ""
Set bal_A = CelH.FirstChild.appendchild(HtmlDoC.createelement("a"))
bal_A.setattribute "href", r.Cells(LiG, C).Hyperlinks(1).Address
bal_A.innerhtml = r.Cells(LiG, C).Value
End If
With CelH.Style
.Width = Round(r.Columns(C).Width) & "pt"
.Height = Round(r.Rows(LiG).Height) & "pt"
.borderleft = "0.5pt solid " & ConvertColorToHtmL(RGB(230, 230, 255))
If r.Cells(LiG, C).Borders(xlEdgeLeft).LineStyle <> xlLineStyleNone Then
.borderleftcolor = ConvertColorToHtmL(r.Cells(LiG, C).Borders(xlEdgeLeft).Color)
End If
If r.Cells(LiG, C).Font.Name <> Fn Then .fontfamily = r.Cells(LiG, C).Font.Name
If r.Cells(LiG, C).DisplayFormat.Font.Color <> FC Then
If Not IsNull(r.Rows(LiG).DisplayFormat.Font.Color) Then
TR.Style.Color = ConvertColorToHtmL(r.Rows(LiG).DisplayFormat.Font.Color)
Else
.Color = ConvertColorToHtmL(r.Cells(LiG, C).DisplayFormat.Font.Color)
End If
End If
Al = r.Cells(LiG, C).HorizontalAlignment 'l'alignement horizontal du texte pour la cellule
ALR = r.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
VaL = r.Cells(LiG, C).VerticalAlignment 'l'alignement horizontal du texte pour la cellule
VaLR = r.Cells(LiG, C).VerticalAlignment 'l'alignement horizontal du texte pour la ligne complète
VaL = Switch(VaL = xlTop, "top", VaL = xlCenter, "middle", VaL = 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(VaL) Then CelH.vAlign = VaL Else CelH.vAlign = "bottom"
End If
End With
Next C
TR.Style.backgroundcolor = ConvertColorToHtmL(r.Rows(LiG).DisplayFormat.Interior.Color)
TR.Style.bordertop = "0.5pt solid " & ConvertColorToHtmL(RGB(230, 230, 255))
Next LiG
ListObjectToTableHTML = TableH.outerhtml
Set HtmlDoC = Nothing
Set TR = Nothing
Set CelH = Nothing
End Function
Public Function ConvertColorToHtmL(C) As String
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
Dim str0 As String, strf As String
str0 = Right("000000" & Hex(C), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
ConvertColorToHtmL = "#" & strf & ""
End Function