XL 2019 tableau excel vers html

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
J

jclaborde

XLDnaute Junior
Bonjour
Concernant le passage d'un tableau excel vers une page html
La fonction ListObjectToHTML de Patricktoulon le permet
et fonctionne très bien
Ce qu'il me manque dans cette fonction est la possibilité de passer lorsqu'une cellule
contient
cellule [C7] par exemple
1 soit une valeur et un hyperlink
[C7].value = "Site download.com" ET [C7]..Hyperlinks(1).Address ="https://www.download.com/"
ou
2 soit une valeur sans hyperlink correspondant
[C7].value = "https://www.download.com/"
ou
[C7].value = " D:\USER\Documents\TEST\swephprg.2.10 Manuel.txt"

que la balise <a href ...> correspondante dans le TD généré

J'ai essayé quelque chose comme cela dim QLink
Set QLink = doc.createElement("a"): TD.appendChild (QLink)
Call QLink.setAttribute("href", texte)
Call QLink.setAttribute("target", "_blank")
Call QLink.setAttribute("Text", "&amp;bull;&amp;equiv;")
mais cela ne s'inscrit pas dans le code html généré ou ne fonctionne pas

Merci de votre réponse
jcl
 

Pièces jointes

Dernière édition:
Solution
patricktoulon
re
pour le coup j'envoie la patate tout de suite comme ça c'est fait
il reconnais
  1. les liens hypertexte +adresse
  2. les chaine string représentant un lien http...
  3. et enfin les chemins de fichier
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //...
Trier par date Trier par votes
Bonjour
mise à jour version1.1
Ajout de la reproduction des liens hypertext cliquable dans le html
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                           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
Voilà 😉
 
Vote positif 0 Vote négatif
merci beaucoup pour la mise à jour

En fait j'utilisais ton programme RANGE TO HTML et la fonction
code = CreateTableBase2(rng, DisplayGriLine)
ou il suffisait de passer un range en paramètre
alors que la il faut passer tableau As ListObject
dans la fonction Function ListObjectToTableHTML
et comme je suis pas très callé
je ne sais pas ce qu'est ce parametre
Je vais essayer de me débrouiller et tester et tester jusqu'à

merci encore
jcl
 
Vote positif 0 Vote négatif
re la fonction Range to html c'est pour une plage de cellules
elle est plus complète dans le sens ou je vais plus loin y compris la gestion des fusions

la petite sœur Listobject to html elle, elle est juste pour les tableaux structurés
du coup je l'ai mis à jour dans la ressources et sera dispo dans quelques jours, cela dit tu en a eu la primeur
 
Vote positif 0 Vote négatif
Tout fonctionne
J'ai juste rajouté pour mon besoin de linker
si le Value est un répertoire
ou
si le Value est une adresse http sans hyperlink

' si hyperlink
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

' si adresse http sans hyperlink
ElseIf r.Cells(LiG, C).Hyperlinks.Count = 0 And Left(r.Cells(LiG, C), 4) = "http" Then
CelH.FirstChild.innerHTML = ""
Set bal_A = CelH.FirstChild.appendChild(HtmlDoC.createElement("a"))
bal_A.setAttribute "href", r.Cells(LiG, C).Value
bal_A.innerHTML = r.Cells(LiG, C).Value
End If

' si repertoire local à améliorer car Dir(cel) <> "" provoque une erreur
If r.Cells(LiG, C).Hyperlinks.Count = 0 _
And r.Cells(LiG, C).Text Like "*\*" _
And r.Cells(LiG, C).Text Like "*:*" _
And r.Cells(LiG, C).Text Like "*.*" Then
CelH.FirstChild.innerHTML = ""
Set bal_A = CelH.FirstChild.appendChild(HtmlDoC.createElement("a"))
bal_A.setAttribute "href", r.Cells(LiG, C).Value
bal_A.innerHTML = r.Cells(LiG, C).Value
End If
 
Vote positif 0 Vote négatif
re
pour le coup j'envoie la patate tout de suite comme ça c'est fait
il reconnais
  1. les liens hypertexte +adresse
  2. les chaine string représentant un lien http...
  3. et enfin les chemins de fichier
VB: 
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'                           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 = V
            End If

            If V Like "[A-z]" & ":\*" Or V Like "http*:/*" Then
            CelH.FirstChild.innerhtml = ""
                Set bal_A = CelH.FirstChild.appendchild(HtmlDoC.createelement("a"))
                bal_A.setattribute "href", CStr(V)
                bal_A.innerhtml = V
            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
voili voilou 😉
 
Vote positif 0 Vote négatif
Solution
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

J
  • Question Question
Creer un mail html a partir d'un Tableau excel
Réponses
2
Affichages
3 K
jammy17
J
T
  • Question Question
Récupérer code html des cellules d'un tableau Web vers Excel
Réponses
4
Affichages
3 K
ttlan
T
G
  • Question Question
tableau html depuis excel
Réponses
0
Affichages
2 K
gadget
G
M
[REF] Wiki Page 8 de MichelXld
Réponses
0
Affichages
39 K
MichelXld
M
Retour