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
tu es prêt à tester

 

[Dudu2]

Envoie...
La version avec WebBrowser et la version sans.

 

[patricktoulon]

re
non la version sans webbrowser
ne pouvant pas tester par moi même le retour b64 comme chez toi chez moi je l'ai laissé de coté
ensuite vu que W10 et + va de plus mal en pis j'ai préféré tout compiler avec des librairies qui j'en suis sur(pour l'instant) ne vous feront pas défaut

je te l'accorde la version avec captureX(le webbrowser) était plus rapide c'est vrai

pour l'instant tout fonctionne sauf pour le b64 qui même avec le code du lien que tu a donné pixelise les image avec un poids plus important
apres recherche dans mes vieux truc html vba je faisait pas comme ca avant
j'utilisais open for binnary au lieu d'un object stream pour lire les bytes du fichier
peut etre est ce là le bas qui blesse le streamer serait limité

 

[Dudu2]

Bonjour @patricktoulon,
T'en es où à ce jour ? Tu attends la publication de ta ressource ?

 

[patricktoulon]

re
Bonjour @Dudu2
non je ne l'ai pas publié
j'ai trouvé le moyen de faire un seul code html compatible outlook et FF et IE
IE voyant légèrement plus grand

je me pose la question si je laisse les anciennes fonctions html ou pas

le procédé adopté
récup des image dans le zip du fichier XL
createrange html par code
create embbed image pour outlook et web dans le même code

je fait plu sieur projet en même temps quand je cale sur 1 je poursuit l'autre comme ça je ne cale pas

après j'en ai plublié 2 autres de ressources (pour le zip et les image )qui ne sont toujour pas validées
alors faut prendre son temps a mon avis c'est pas la peine de se presser

 

[patricktoulon]

Bonjour @Dudu2
la nouvelle version a été publiée (en attente d’approbation)
V4.3
testé sur des pcs windows 10 et Windows 7 excel 2007,2013,2016

 

[Dudu2]

Bonjour @patricktoulon,
Ok, j'attends la publication avec impatience. En principe il fait ça le dimanche soir d'après mon expérience, sauf exception.

 

[Dudu2]

2 petites remarques:
1 - Alignement vertical de T1
Excel:

IE:

2 - Les images sont précédées d'un point sur la version IE:

 

[Dudu2]

Sacré boulot que t'as fait là ! Avec un joli code commenté

 

[patricktoulon]

re
oui je l'ai remarqué le margin-left du td.firstchild de fonctionne pas dans outlook
j'ai essayé de rendre le plus fidele a l'original
les point c'est bizarre c'est les balises "<li> que je me sert provisoirement
je vais regarder ça
j'ai peut être bloqué la ligne je sais pas
y en a tellement

 

[patricktoulon]

re
je viens de regarder et chez moi elle sont bien enlevées et remplacer par la condition "SI pas MSO"
regarde
exemple le 1er embbed obtenu

<!--[if mso]>
<v:rect style="POSITION: absolute; WIDTH: 30.75pt; HEIGHT: 25.575pt; TOP: 2pt; LEFT: 8pt" xmlns:v="urn:schemas-microsoft-com:vml" fill="true" stroke="false" ><v:fill  type="frame" src="Smiley_Face_1.png">
</v:fill></v:rect>
<![endif]-->
<!--[if !mso]><!-- -->
<IMG style="POSITION: absolute; WIDTH: 32.287pt; HEIGHT: 24.877pt; TOP: 2pt; LEFT: 8pt" src="images_table_C4_I13\Smiley_Face_1.png">
<!--<![endif]-->

renvoie moi le code du fichier html que tu obtiens

 

[Dudu2]

.html IE en .txt
Attention: je parle pas de Outlook.

 

[Dudu2]

C'est peut-être les balises <Li> que tu remplaces pour Outlook mais qui ne servent pas pour IE.

 

[Dudu2]

Parce que pour Outlook, j'ai un autre souci:

 

[patricktoulon]

re
ben je vois en fait chez toi le replace ne se fait pas la je pige pas
c'est vraiment trop bizarre ton install ca n'a rien a voir avec outlook
c'est dans la fonction PutShapOnHtmlOutlook que ça se passe
tout du moins chez toi ça se passe pas

edit:
ok c'est pigé chez toi les balise sont en minuscule
donc adaptation de la fonction dans ce sens

change la

'****************************************************************************************************
Function PutShapOnHtmlOutlook(CdeHTML$, RnG As Range, Optional ByVal DossierImage$ = "")
'Function d'ajout des images 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
    DcO.body.innerhtml = CdeHTML
    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 = Int(shap.Top - cel.Top) & "pt"
                .Width = Replace(shap.Width, ",", ".") & "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 - 1) & "pt"
                .Top = Int(shap.Top - cel.Top) & "pt"
                .Width = Replace(shap.Width * 1.05, ",", ".") & "pt"
                .Height = Replace(shap.Height * 1.07, ",", ".") & "pt"
            End With
            ImG.src = Mid(DossierImage, InStrRev(DossierImage, "\") + 1) & "\" & Replace(shap.Name, " ", "_") & ".png"
            Set VfilL = DcO.createElement("pre")
            VfilL.setattribute "type", "frame"
            VfilL.setattribute "bal", "v:fill"
            VfilL.setattribute "src", 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 = code
    Set DcO = Nothing
End Function
'******************************************************************************************