Icône de la ressource

Fonction ListObjectToHTML 1.1

Inscrivez vous pour télécharger ce fichier
Vue principale Mises à jour (1) Historique Discussion
Laisser une appréciation
Bonjour à tous
comme le sujet (envoyer une plage de cellules dans le corps du mail) revient inlassablement sur le forum
je vous livre aujourd'hui ma fonction ListObjectToTableHTML

Cette fonction ne peut recevoir comme argument qu'un objet listobject (l'object range est exclu)

cette fonction encode en html une table html représentant le tableau structuré le plus fidèlement possible
cette fonction est issue de ma fonction range toHTML mais elle est ultra simplifié

le code html résultant peu être injecté dans le bodyhtml du mailitem(0) de outlook par exemple
ou même être enregistré dans un fichier html ou txt pour une utilisation autre et/ou ultérieure

Alors certains vont s’empresser de me dire que l'on peut copier coller dans le corps du mail outlook en passant par l'inspector et les range du document(outlook)
sauf que l'on est obligé dans ce cas là de faire un display avant pour pouvoir coller
avec ma méthode l'object outlook peut rester invisible
d'autant plus que pour les destinataires n'utilisant pas outlook comme application mail
se retrouvent avec une page parfois désordonnée(a méditer)

donc ceci étant dit

le code de la fonction

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)
'***************************************************************************************************
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$
    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 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
            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 .Color = ConvertColorToHtmL(r.Cells(LiG, C).DisplayFormat.Font.Color)
                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

un code exemple d'utilisation pour Outlook

VB: 
Option Explicit
Sub TestAvecOutlook()
    Dim OL As Object, OLmail, code, Corps
    Set OL = CreateObject("Outlook.Application")
    Set OLmail = OL.CreateItem(0)    '0
    code = ListObjectToTableHTML(Range("Tableau1").ListObject)
    With OLmail
        '.From = CStr("guillaumepothier@hotmail.com")
        .To = "dudu@youmémélle.com"
        .Subject = "test listobject" & Date
        .BodyFormat = 2
        Corps = "<div style=""font-family:calibri;font-size:11pt;"">"
        Corps = Corps & "bonjour salut<br>ci-joint le tableau des ventes du mois<br>"
        Corps = Corps & code
        Corps = Corps & "<br><br>en vous souhaitant bonne reception<br>patrick à votre service"
        Corps = Corps & "</div>"
        .htmlbody = Corps
        .display
        '.Save
        '.Send 'envoi automatique
    End With
End Sub

un code exemple pour enregistrer dans un fichier HTML (exploitable par tout navigateur)

VB: 
Sub TestCreateHtmlFile()
    Dim fichier$, X&, code$
    'fichier = Environ("userprofile") & "\Desktop\table.html"
    fichier = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & "table.html"
    code = ListObjectToTableHTML(Range("Tableau1").ListObject)
    X = FreeFile: Open fichier For Output As #X: Print #X, code: Close #X
End Sub

capture du résultat outlook
vue1.JPG



capture du renderer sur firefox par exemple pour un fichier html
vue2.JPG


voilà c'est une petite fonction bien utile aux vues du nombre de demandes de ce genre que l'on voit passer chaque année sur le forum j'ai pensé que ça pouvait vous être utile

Bonne utilisation ;)
Auteur
patricktoulon
Version
1.0 - 2024
  • J'aime
Réactions: Tsimbina, Lolote83 et D. HANIB
Auteur
patricktoulon
Téléchargements
28
Affichages
860
Sortie
Dernière mise à jour
Évaluation
0.00 étoiles(s) 0 notes
Rejoignez la discussion

Plus de ressources de patricktoulon

Partager cette ressource

Dernières mises à jour

  1. Fonction ListObjectToHTML +hyperlink

    Bonjour à tous voici une petite mise à jour que j'ai effectué par rapport à une demande...
Lire la suite…