XL 2016 VBA - Range to HTML incluant les objets de la feuille (boutons, images, ...)

[Dudu2]

Bonjour,

Je n'ai rien trouvé qui fonctionne pour convertir un Range en HTML qui inclurait tout ce qu'il y a dans le Range en question.

J'ai bien récupéré la fonction de Ron de Bruin omni-présente sur le Web qui fonctionne uniquement pour les valeurs de cellules et leurs formats, sauf pour les tableaux structurés qui ne sont pas en exclusivité dans le Range qui perdent alors leurs formats (qui n'en sont pas vraiment !).

 

[patricktoulon]

re
avant le publish
je n'ajoute rien a coté du tableau
je le met sur la derniere cellule en bas a droite si elle est vide

' on crée le code html en le recuperant du publich
Function CreateHtmlPublish(rng As Range, fichier)
   'function created By patricktoulon date(09/2022)
 Dim lachaine As String, x, code, y, TempWB As Workbook, dhtml As New HTMLDocument, tb, TdS, TrS, cel, addr$, A, i&, C&
    Dim table1, tablecalque, tr, TD
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Set TempWB = Workbooks.Add
    With rng
        If .Cells(.Cells.Count) = "" Then .Cells(.Cells.Count) = "|"
        rng.Copy TempWB.Sheets(1).[A1]    ' le (copy To Destination ) est plus rapide  que le (copy et sheet temp.paste......)
        .Cells(.Cells.Count) = ""
    End With
    With TempWB.Sheets(1)
        .DrawingObjects.Delete
        For i = 1 To rng.Columns.Count: .Columns(i).ColumnWidth = rng.Columns(i).ColumnWidth: Next
    End With
    DoEvents
    'publie la feuille en fichier html
    With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=fichier, _
                                   Sheet:=TempWB.Sheets(1).Name, Source:=TempWB.Sheets(1).UsedRange.Address, _
                                   HtmlType:=xlHtmlStatic): .Publish (True)
    End With
    DoEvents
    ActiveWorkbook.Close

    'apres  avoir publié on recupere le code du fichier
    x = FreeFile: Open fichier For Binary Access Read As #x: lachaine = String(LOF(x), " "): Get #x, , lachaine: Close #x

    'on récupere en string le code de la table uniquement
    tb = "<table" & Split(Split(lachaine, "<table")(1), "</table>")(0) & "</table>"

    'on la met dans un htmldocument
    dhtml.body.innerHTML = tb


    'on la determine en tant qu'object  table1
    Set table1 = dhtml.getElementsByTagName("table")(0)
    'on collectionne les ligne(tr)de cette table
    Set TrS = table1.getElementsByTagName("tr")
    'on crée en memoire( sans afillier au document une table qui va nous servir de calque )
    Set tablecalque = dhtml.createElement("table")
    For i = 1 To rng.Rows.Count    'boucle sur ligne de rng
        Set tr = tablecalque.appendchild(dhtml.createElement("tr"))    'on crée une ligne tr pour chaque ligne de rng
        A = 0    'A on remet A a 0 achaque tour de ligne
        For C = 1 To rng.Columns.Count    'boucle sur colonne de rng
            addr = rng.Cells(i, C).MergeArea.Address(0, 0)    'on determine l'address de la cellule
            'si cet element n'existe pas dans le document ou la  table calque
            If dhtml.getElementById(addr) Is Nothing Then
                'alors
                A = A + 1
                'on le crée et on lui met  le id (addr)
                Set TD = tr.appendchild(dhtml.createElement("td")): TD.ID = addr

                'on prend le meme dans la table d'origine et on lui met le meme ID
                'on gere l'erreur  due au fait que rng a 8 colonne  tandis que la copy en html donc table1 n'en a que 4
                On Error Resume Next
                TrS(i - 1).Children(A - 1).ID = addr
                If TrS(i - 1).Children(A - 1).innerHTML = "|" Then TrS(i - 1).Children(A - 1).innerHTML = ""
                On Error GoTo 0
            End If
        Next
    Next
    'on peut supprimer la tablecalque  on en a plus besoins
    Set tablecalque = Nothing
    'on remplace dans le string du fichier le code de la table par le code de la table1
    lachaine = Replace(lachaine, tb, dhtml.getElementsByTagName("table")(0).outerhtml)
    'pas vraiment necessaire mais pour que tu puisse voir je réécris le fichier publié  avec la table et ces cellule avec ID
    x = FreeFile: Open fichier For Output As #x: Print #x, lachaine: Close #x
    'le return de la fonction c'est le code complet
    CreateHtmlPublish = Replace(lachaine, "align=center x:publishsource=""Excel""", "")
End Function

 

[Dudu2]

je le met sur la derniere cellule en bas a droite si elle est vide

Ok et ça suffit pour que Publish génère toutes les TD ?
De toutes façons si la dernière cellule jouxte un tableau structuré, ça va quand même étendre ce tableau structuré.

 

[patricktoulon]

re
ben oui bien sur
une autre solution serait d'ajouter une shape de 1 point de large et 1 point de haut dans la dernière cells avant de publier comme il y a une shape il prendra en compte la totalité de la plage
reste a voir comment supprimer cette shape dans le HTML résultant

sur la dernière version j'exporte tout en publish html et shapes
ca fonctionne mais je gagne vraiment pas grand chose en terme de temps d’exécution par rapport au zippage
certes la table a la même dimension que l'original mais c'est tout ce que l'on gagne
par contre en cas de fusion inter croisées , la c'est bien évidement la grosse déception
mais ça on le sait

 

[patricktoulon]

re
Alors dans tout ça y a rien qui fait l'affaire ???
allez j'annonce and (All by publish)
dans un module tu met
ceci

Option Explicit
'sub de test
Sub testByPublish()
    Dim Fichierhtml$, dossier$, rng As Range, codetable$, x&, tim#, cel As Range
    tim = Timer
    Fichierhtml = Environ("userprofile") & "\Desktop\toto.htm"
    dossier = Replace(Fichierhtml, ".htm", "_fichiers")    'pour plus tard  recupérer les shapes
    Set rng = [c4:i13]

    codetable = CreateHtmlPublish(rng, Fichierhtml)    'on récupere le code html par le publish

    'DrawingObjects_To_Png_File3 rng, dossier
    Export_Shape_To_Png_File rng, dossier

    codetable = PutShapOnHtmlOutlook(codetable, rng, dossier)
    x = FreeFile: Open Fichierhtml For Output As #x: Print #x, codetable: Close #x
    'MsgBox Format(Timer - tim, "#0.000 Sec") & " pour obtenir le code avec publish"
    SendSelectionWithOutlook1 CStr(codetable), dossier   '
End Sub

' on crée le code html en le recuperant du publich
Function CreateHtmlPublish(rng As Range, fichier)
    Dim lachaine As String, x, code, y, TempWB As Workbook, dhtml As New HTMLDocument, tb, TdS, TrS, cel, addr$, A, i&, C&
    Dim table1, tablecalque, tr, TD
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    Set TempWB = Workbooks.Add
    With rng
        If .Cells(.Cells.Count) = "" Then .Cells(.Cells.Count) = "|"
        rng.Copy TempWB.Sheets(1).[A1]    ' le (copy To Destination ) est plus rapide  que le (copy et sheet temp.paste......)
        .Cells(.Cells.Count) = ""
    End With
    With TempWB.Sheets(1)
        .DrawingObjects.Delete
        For i = 1 To rng.Columns.Count: .Columns(i).ColumnWidth = rng.Columns(i).ColumnWidth: Next
    End With
    DoEvents
    'publie la feuille en fichier html
    With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, Filename:=fichier, _
                                   Sheet:=TempWB.Sheets(1).Name, Source:=TempWB.Sheets(1).UsedRange.Address, _
                                   HtmlType:=xlHtmlStatic): .Publish (True)
    End With
    DoEvents
    ActiveWorkbook.Close

    'apres  avoir publié on recupere le code du fichier
    x = FreeFile: Open fichier For Binary Access Read As #x: lachaine = String(LOF(x), " "): Get #x, , lachaine: Close #x

    'on récupere en string le code de la table uniquement
    tb = "<table" & Split(Split(lachaine, "<table")(1), "</table>")(0) & "</table>"

    'on la met dans un htmldocument
    dhtml.body.innerHTML = tb


    'on la determine en tant qu'object  table1
    Set table1 = dhtml.getElementsByTagName("table")(0)
    'on collectionne les ligne(tr)de cette table
    Set TrS = table1.getElementsByTagName("tr")
    'on crée en memoire( sans afillier au document une table qui va nous servir de calque )
    Set tablecalque = dhtml.createElement("table")
    For i = 1 To rng.Rows.Count    'boucle sur ligne de rng
        Set tr = tablecalque.appendchild(dhtml.createElement("tr"))    'on crée une ligne tr pour chaque ligne de rng
        A = 0    'A on remet A a 0 achaque tour de ligne
        For C = 1 To rng.Columns.Count    'boucle sur colonne de rng
            addr = rng.Cells(i, C).MergeArea.Address(0, 0)    'on determine l'address de la cellule
            'si cet element n'existe pas dans le document ou la  table calque
            If dhtml.getElementById(addr) Is Nothing Then
                'alors
                A = A + 1
                'on le crée et on lui met  le id (addr)
                Set TD = tr.appendchild(dhtml.createElement("td")): TD.ID = addr

                'on prend le meme dans la table d'origine et on lui met le meme ID
                'on gere l'erreur  due au fait que rng a 8 colonne  tandis que la copy en html donc table1 n'en a que 4
                On Error Resume Next
                TrS(i - 1).Children(A - 1).ID = addr
                If TrS(i - 1).Children(A - 1).innerHTML = "|" Then TrS(i - 1).Children(A - 1).innerHTML = ""
                On Error GoTo 0
            End If
        Next
    Next
    'on peut supprimer la tablecalque  on en a plus besoins
    Set tablecalque = Nothing
    'on remplace dans le string du fichier le code de la table par le code de la table1
    lachaine = Replace(lachaine, tb, dhtml.getElementsByTagName("table")(0).outerhtml)
    'pas vraiment necessaire mais pour que tu puisse voir je réécris le fichier publié  avec la table et ces cellule avec ID
    x = FreeFile: Open fichier For Output As #x: Print #x, lachaine: Close #x
    'le return de la fonction c'est le code complet
    CreateHtmlPublish = Replace(lachaine, "align=center x:publishsource=""Excel""", "")
End Function

and you add this code of my function PutShapOnHtmlOutlook
you now this function now
I no longer need to introduce her to you

'****************************************************************************************************
Function PutShapOnHtmlOutlook(CdeHTML$, rng As Range, Optional ByVal DossierImage$ = "")
'Function d'ajout des emmbeds image dans le code html d'une cellule TD html en utilisant 2 balises "PRE"
'retransformé en en code shape:VML pour outlook
'patricktoulon (2022)
    Dim DcO As New HTMLDocument, Shap As Object, cel As Range, TD, VrecT, VfilL, addr$, dossier
    Dim pres, A&, bal$, deb$, fin$, code$, ImG, Li, tb
    'on récupere en string le code de la table uniquement
    tb = "<TABLE" & Split(Split(CdeHTML, "<TABLE")(1), "</TABLE>")(0) & "</TABLE>"

    DcO.body.innerHTML = tb
    For Each Shap In rng.Parent.DrawingObjects
        Set cel = Shap.TopLeftCell.MergeArea
        addr = cel.Address(0, 0)
        If Not Intersect(Shap.TopLeftCell, rng) Is Nothing Then
            Set TD = DcO.getElementById(addr)
            Set TD = DcO.getElementById(addr): TD.Style.Position = "relative"
            TD.Style.Position = "relative"
            Set Li = DcO.createElement("LI")
            Set ImG = DcO.createElement("IMG")
            Li.appendchild (ImG)
            Set VrecT = DcO.createElement("pre")
            VrecT.setattribute "xmlns:v", "urn:schemas-microsoft-com:vml"
            VrecT.setattribute "fill", "true"
            VrecT.setattribute "stroke", "false"
            VrecT.setattribute "bal", "v:rect"
            With VrecT.Style
                .Position = "absolute"
                .Left = Int(Int(Shap.Left) - cel.Left) - 1 & "pt"
                .Top = Replace(Shap.Top - cel.Top - 1, ",", ".") & "pt"
                .Width = Replace(Shap.Width + 1, ",", ".") & "pt"
                .Height = Replace((Shap.Height * 1.1), ",", ".") & "pt"
            End With
            TD.appendchild (VrecT)
            With ImG.Style
                .Position = "absolute"
                .Left = Int(Int(Shap.Left) - cel.Left) & "pt"
                .Top = Replace(Shap.Top - cel.Top, ",", ".") & "pt"
                .Width = Replace(Shap.Width, ",", ".") & "pt"
                .Height = Replace((Shap.Height), ",", ".") & "pt"
                .zIndex = 1
            End With
            A = A + 1
            ImG.src = Mid(DossierImage, InStrRev(DossierImage, "\") + 1) & "\" & "image" & A & ".png"    ' Replace(shap.Name, " ", "_") & ".png"
            Set VfilL = DcO.createElement("pre")
            VfilL.setattribute "type", "frame"
            VfilL.setattribute "bal", "v:fill"
            VfilL.setattribute "src", "image" & A & ".png"    ' Replace(shap.Name, " ", "_") & ".png"
            VrecT.appendchild (VfilL)
            TD.appendchild (Li)
        End If

    Next
    Set pres = DcO.getElementsByTagName("PRE")
    For A = pres.Length - 1 To 0 Step -1
        bal = pres(A).getattribute("bal")
        If InStr(pres(A).outerhtml, "<pre") > 0 Then
            pres(A).outerhtml = Replace(Replace(pres(A).outerhtml, "<pre", "<" & bal), "pre>", vbCrLf & bal & ">")
        Else
            pres(A).outerhtml = Replace(Replace(pres(A).outerhtml, "<PRE", "<" & bal), "PRE>", vbCrLf & bal & ">")
        End If
    Next
    deb = "<!--[if mso]>": fin = "<![endif]-->"
    code = DcO.body.innerHTML
    code = Replace(code, "</ v:rect>", "")
    code = Replace(code, "</ v:fill>", "")
    code = Replace(code, "<v:rect", vbCrLf & deb & vbCrLf & "<v:rect")
    code = Replace(code, "</v:rect>", "</v:rect>" & vbCrLf & fin)
    code = Replace(code, "</v:fill>", vbCrLf & "</v:fill>")
    code = Replace(code, "<?xml:namespace prefix = v />", "")
    code = Replace(code, "bal=""v:rect""", "")
    code = Replace(code, "bal=""v:fill""", "")

    If InStr(1, code, "<li>") > 1 Then
        code = Replace(code, "<li>", "<!--[if !mso]><!-- -->" & vbCrLf)
        code = Replace(code, "</li>", vbCrLf & "<!--<![endif]-->" & vbCrLf)
    Else
        code = Replace(code, "<LI>", "<!--[if !mso]><!-- -->" & vbCrLf)
        code = Replace(code, "</LI>", vbCrLf & "<!--<![endif]-->" & vbCrLf)
    End If
    PutShapOnHtmlOutlook = Replace(CdeHTML, tb, code)
    Set DcO = Nothing
End Function

and you add this function to extract the images in png

Option Explicit
Sub test()
    Export_Shape_To_Png_File [c4:i13]
End Sub
Function Export_Shape_To_Png_File(rng As Range, Optional dossier$ = "")
    Dim tempo$, tempoF$, f As Worksheet, i&, Shap As Object
        With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    If dossier = "" Then dossier = ThisWorkbook.Path & "\Images"
    If Dir(dossier, vbDirectory) <> "" Then DeleteFolderInOneShot3 dossier, True
    DoEvents
    MkDir dossier
    tempo = Environ("userprofile") & "\desktop\tempo.htm"
    tempoF = Replace(tempo, ".htm", "_fichiers")
    Set f = Workbooks.Add.Sheets(1)
    For i = 1 To rng.Parent.DrawingObjects.Count
        Set Shap = rng.Parent.DrawingObjects(i)
        If Not Intersect(Shap.TopLeftCell, rng) Is Nothing Then
            Shap.Copy: f.Pictures.Paste:
            With ActiveWorkbook.PublishObjects.Add(xlSourceSheet, tempo, "Feuil1", "", xlHtmlStatic, "X" & i, "")
                .Publish (True): .AutoRepublish = False
            End With
            Name tempoF & "\X" & i & "_image001.png" As dossier & "\image" & i & ".png"
            f.DrawingObjects.Delete
        End If
    Next
f.Parent.Close
DoEvents
Kill tempo
DeleteFolderInOneShot3 tempoF
End Function

Function DeleteFolderInOneShot3(dossier$, Optional waiting As Boolean = False)
Kill dossier & "\*"
RmDir dossier
End Function

npw you can make any jump function you want it's simplicity always which will be effective
Enjoy my firend
LOL

 

[Dudu2]

L'ancien code fonctionnait...
Mais le nouveau:

 

[Dudu2]

Pour info j'ai fait un code qui n'utilise pas la Microsoft HTML Library, ni pour les Tag id=<cellule> que j'utilise aussi pour simplifier les recherches en String, ni pour les Tags images MSO et non-MSO que je fabrique manuellement.

Ça fonctionne en fichier et en mail Outlook. Il y a de petites différences de placement car j'utilise les Top / Left des DrawingObjects par rapport au Range ou aux cellules qui les contiennent. Mais ça reste acceptable.

Dans ce fichier pour générer un fichier .htm, il y a mon code et ton code (l'ancien car le dernier plante) qui peut être choisi en L1

Je joins aussi le même genre de classeur pour générer un mail Outlook.

Par contre, en Thunderbird, les mails envoyés pas Outlook sont toujours non WYSIWYG.
La faute à Outlook, je pense qu'il n'y a rien à faire.

 

[Dudu2]

Voilà les fichiers... Je crois qu'on est proches de la fin de l'histoire !

 

[patricktoulon]

re
ma fois pour ma part j'ai 3 versions qui fonctionnent avec la tienne ça fait 4

 

[patricktoulon]

re
bonjour @duduz
ce matin donc Test de ta dernière mouture
1 ° test ok (c'est un peu long mais acceptable)
2° Test (j'ai ajouté deux étoiles dans ta table )
résultat

 

[Dudu2]

bonjour @patricktoulon,
Ah ah ! Prompt à détecter mes bugs
Note qu'avec ton code c'est pas mieux !

 

[Dudu2]

Je crois savoir d'où ça vient. De mon export des images.
D'où l'utilité d'un test complexe de cellules fusionnées.

 

[Dudu2]

Ok... Tu as bien fait de tester ça !
Une instruction à changer dans la capture des images:
Set TopLeftCell = Shp.TopLeftCell -> Set TopLeftCell = Shp.TopLeftCell.MergeArea.Cells(1)

 

[patricktoulon]

non en fait l'erreur elle viens de "for each shap in..."
on la déjà vu ça en plus je l'ai soulevé il ya quelques messages
j'avais oublié
si des shapes portent le même nom la boucle for each ne fait pas la différence
tandis que la boucle for i= 1 to rng.parent.drawingobjects.count
elle oui elle fait la différence le pire c'est que ca fait plusieurs jour que j'avais trouver la bullette

 

[patricktoulon]

je corrige donc
je copie ton étoile deux fois et leur change leur couleur
et résultat

 

[Dudu2]

si des shapes portent le même nom la boucle for each ne fait pas la différence

AHHHHHHHHHHH ! Merci pour cette info cruciale.
J'avais changé les noms des Shapes dans un cas et pas dans l'autre et je ramais pour trouver pourquoi ça marchait dans le 1er cas et pas dans le 2ème avec le même code sans y arriver.
Tu m'as sauvé d'une galère !