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
d'accords en fait tu le recupere directement en base64

LOL
change lui le code de ce userform pour celui là on va voir

'****************************************************************
'        COLLECTION ASTUCE USERFORM AVEC controls WEBBROWSER    *
'             récuperateur de shapes  en  pngfile(fichier png)  *
'version:1.0                                                    *
'date version:16/08/2022                                        *
'auteur :patricktoulon                                          *
' si le src est en base64
'****************************************************************
Option Explicit
Public shap As Shape
Public fichier$
Public Repertoire_De_Destination$
Public RnG As Range
Public Function GetAllShapOnRangeInOneShotToPngfich(RnG As Range, Optional ByVal Repertoire_De_Destination$ = "")
    Dim Web As Object, Div As Object, R As Range, b#, slash$, D$, NewChemin$, x$, Appcopobj As Boolean, shap As Shape
        Application.ScreenUpdating = False
        With CaptureX
        Set .RnG = RnG
        If Repertoire_De_Destination = "" Then Repertoire_De_Destination = Environ("userprofile") & "\DeskTop\Captures"
          '.StartUpPosition = 0: .Left = 3000
        If Dir(Repertoire_De_Destination, vbDirectory) = "" Then MkDir Repertoire_De_Destination
        Appcopobj = Application.CopyObjectsWithCells
        Application.CopyObjectsWithCells = True

        Set Web = Me.Controls.Add("Shell.Explorer.2", "wb1")    'ajoute un webbrowser dynamiquement
        With Web
            .Navigate "about:blank"    'ouvre une page vierge
            Do While .readystate < 4: DoEvents: Loop    'attente qu readystate complete
            'ajout d'une balive div(layer) editable
            Set Div = .Document.body.appendchild(.Document.createElement("div")): Div.contenteditable = True

            For Each shap In RnG.Parent.Shapes
                Div.innerhtml = ""
                If Not Intersect(RnG, shap.TopLeftCell) Is Nothing Then
                    b = shap.Left: shap.Left = 2000    'on deplace la shape loin pour qu'il n'y ai qu'une shape dans la capture
                    Set R = shap.Parent.Range(shap.TopLeftCell, shap.BottomRightCell)

                    'on copy la plage et on la colle dans le div  avec execWb
                    R.Copy: Div.Focus: .ExecWB 13, 2
                    Do While .Busy: DoEvents: Loop    'on lui laisse le temps de tout coller
                    shap.Left = b    'on remet la shape à sa place

                    'on recupere le le seul lien SRC qu'il y a dans le code html du document
                    D = Split(Split(Div.innerhtml, "data:image/png;base64,")(1), " v:shapes")(0) & ".png"
                    
                    If Right(Repertoire_De_Destination, 1) <> "\" Then slash = "\"
                    NewChemin = Repertoire_De_Destination & slash & Replace(shap.Name, " ", "_") & ".png"
                    If Dir(NewChemin) <> "" Then Kill (NewChemin)
                  
                       Base64tofichier D, NewChemin

                    End If
                End If
            Next
        End With
    End With

    Application.CopyObjectsWithCells = Appcopobj
    Unload Me
End Function

Function Base64tofichier(ByVal strData As String, ByVal chemin As String)    ' As Object
    Dim XmlDoc As Object, objNode As Object, a() As Byte, Buffer() As Byte, intFileNumber
    Set XmlDoc = CreateObject("MSXML2.DOMDocument")
    With XmlDoc.createElement("b64")
        .DataType = "bin.base64"
        .Text = strData
        a = .nodeTypedValue
        Set XmlDoc = Nothing
        '///////////////////////////////////
        i& = FreeFile: Open chemin For Binary As #i: Put #i, , a: Close #intFileNumber
    End With
End Function

 

[Dudu2]

 

[Dudu2]

 

[patricktoulon]

re
oui j'ai du oublié d'en enlever un
Attends 5 minutes faut que je fasse pour les deux modes
je reviens avec une version finalisée

 

[patricktoulon]

ha c'est meme pas du base 64 alors
ben puré ......
bon je finalise on verra bien

 

[Dudu2]

Je reviens tout à l'heure.

 

[patricktoulon]

ok

 

[Dudu2]

En attente de ton code...

 

[patricktoulon]

re
il faudrait aussi verifier si tu n'a pas 2 src quand c'est des activx ca m'etonnerait pas vu que moi j'ai deux fichiers (un .emz et un .png )
je tente une emulation IE8/9 pour ne pas chopper en base 64 mais les deux sont possibles
il faut verifier si(2 src)

 

[Dudu2]

J'ai toujours ça, mais pas grave.

Et malheureusement toujours ça:

Sur cette instruction

Debug:
Div.innerhtml =
<table width="240" style="width: 180pt; border-collapse: collapse;" border="0" cellspacing="0" cellpadding="0">

<colgroup><col width="80" style="width: 60pt;" span="3">
<tbody><tr height="20" style="height: 15pt;">
<td width="80" height="20" align="left" valign="top" style="border: 0px black; width: 60pt; height: 15pt; background-color: transparent;"><span style="margin: 1px auto auto 26px; width: 150px; height: 98px; position: absolute; z-index: 3; mso-ignore: vglayout;"><img width="150" height="98" src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAJYAAABiCAYAAACyAirtAAAAAXNSR0ICQMB9xQAAAAlwSFlzAAAOxAAADsQBlSsOGwAAABl0RVh0U29mdHdhcmUATWljcm9zb2Z0IE9mZmljZX/tNXEAAAVuSURBVHja7d3fT1tlHMdx/gx/xET/BhMvRDinheHEDtiARS1s/ogxLt2hpzWwCxOtGQxQN5nBcjjntJsmu/Jm08l0Y0YDQky80gE2WUz8PTbFuF8yoo/POS2lIRmD9bTQ9n3xSbhryXnl83162uc5VT7dEmrXqFC0EbIJaThwQvgj5uuxWKyqnFLloGrqOyPah6ZE6+EJUrRMitYjk6IxdlKoYaP8YCmaIdokqr3HL4rOxPekaEmJzmRKBHrHRK0WL09YrUcm3H82aF4gRcuMCFozInDwE2ARYAELWMACFrAIsIAFLGABC1gEWMACFrCABSwCLGABC1jAAhYBFrCABSxgAYsAC1jAAhawgEWABayKh1WvGfeoUeNhYAHL0yg9xkN+3fxG1e0gsIDlXWP1DN3vi1g/+qPJfySuFmAByztYUXuuMXZK+KPHFhTNbAIWsLyBpVtzbe98JVoGxoX8+69C4QJWBcJqPzotOu050XTorJCj8U81ZDwJLGB50FhT7hZ/5300HfrMaa4FVfcWF7AqFFaHbKwO+fpZXGFLrrmMRmA
BK29Y7vuwZtO4+pzmsq8ouvkEsICVPyyZbHP1fSrULnNBCeWPC1jAyuCaXcGlW5f9IaMBWCUOSwnFXysGrOqe/ntvBysX1w6Jyxc2/6jR4o8DC1jrgGWsCWt1c/kj9iVFM7cBqwRhbX/1Q1EbGk4pWvwjmdOFSu3+kY9rQ++NK9rItV1vfXFbWC4uO7e5rCt3MxaBtclpGTjvngHr3AkvdJr7z4kdvWfE7ne/zn4aXAvXM6Pp5pK45ms0ow5YJRTnE5lzEZ0RVPBkXsdty/W8N7e5vnMx+nTzkroBXMAid4C/gkvtMufletAPLOINLncsZnDp1m+qHleBRbxrrmVcXaPzijbsAxbxDNdyc8kF/S/STi2wiHe4smuu0d/lgl4BFvG2uQ6Oyeayf1a14WpgEc8W9MEMLtlcv8rmegxYxMNPi9+mcemm01yPAot4isv5zlMNWz8tj0VgEW9uRcgFfcBZ0IfNy2rUfgRYxANY6a+lmvvPCn8ksahEzW3AIvnFaSvrQgaVfU2utdoYhST/ESjbyvnVhC9i/10TMtpYvJM8m2rGHYEtA+ecTRg3FC2+m9sNJO81VTCDSo6/q6tRAYvc3UI9p6lq9sWf4isdkvf4y2mq60rIeJovoYmH4y+xJipgkXXfUuhYaaqbaige5Id+xKM11bioiySv14TiHfw0uVQu3BbdTBHMQSWbalGOvz1spiiR5G7/ai5gNrz9KxdVNHlD0Yb3sP2rJLJqw+r+kVOF3LDqbIjNbFi9eqcNq8FMi2ZO/VuS4+9ZNqyWGCx3i722lbbYz7jjsmXQbaqb8r09xxb7UoW1RQ4Fya6pBt011S1V33hTAWsLwdoKxxilb34uN1ViUdHjz3OMEbDyg5UZfzsHz4u6aFJ++ht+gYPXgJXnUZHphbqDSo6/JTmWX+SoSGDlfbhttqleObboFSpgVTIseb2XUcmm+leieonjuIGV3wMEhqbdc953vvm5c0vhlqJ5iwpYlQrr6LTY9faXwq8n/pNN9TKPPA
GWBw9pSswG3jgt6rvfX5LXfh8PaQKWB7CM+2Rj/VDf/YFQC4gKWBUGa3vUftCvWylVt7sL/VrAqiBY1T3GA2rUDBTjtYBVQbCKGWABC1jAAhYBFrCABSxgAYsAC1jAAhawgEWABSxgAQtYwCLA4mIDC1jAAhYBFhccWMACFrAIsAiwvILVNjQl9h6/6OIixUpKdCZTItA7Vp6w1K5R9wzMdomr9fAEKVom5aSYFI2xk0ING+UHy6dbzjN9haKNkE1Iw4ETwh8xyw7W/5rG3+a7bM5eAAAAAElFTkSuQmCC" v:shapes="toto"></span><span style="mso-ignore: vglayout2;"><font face="Calibri">
</font><table cellspacing="0" cellpadding="0"><font face="Calibri">
</font><tbody><tr><font face="Calibri">
</font><td width="80" height="20" style="border: 0px black; width: 60pt; height: 15pt; background-color: transparent;"></td><font face="Calibri">
</font></tr><font face="Calibri">
</font></tbody></table><font face="Calibri">
</font></span></td>
<td width="80" style="border: 0px black; width: 60pt; background-color: transparent;"></td>
<td width="80" style="border: 0px black; width: 60pt; background-color: transparent;"></td>
</tr>
<tr height="20" style="height: 15pt;">
<td height="20" style="border: 0px black; height: 15pt; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
</tr>
<tr height="20" style="height: 15pt;">
<td height="20" style="border: 0px black; height: 15pt; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
</tr>
<tr height="20" style="height: 15pt;">
<td height="20" style="border: 0px black; height: 15pt; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
</tr>
<tr height="20" style="height: 15pt;">
<td height="20" style="border: 0px black; height: 15pt; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
<td style="border: 0px black; background-color: transparent;"></td>
</tr>

</tbody></table>
D = iVBORw0KGgoAAAANSUhEUgAAAJYAAABiCAYAAACyAirtAAAAAXNSR0ICQMB9xQAAAAlwSFlzAAAOxAAADsQBlSsOGwAAABl0RVh0U29mdHdhcmUATWljcm9zb2Z0IE9mZmljZX/tNXEAAAVuSURBVHja7d3fT1tlHMdx/gx/xET/BhMvRDinheHEDtiARS1s/ogxLt2hpzWwCxOtGQxQN5nBcjjntJsmu/Jm08l0Y0YDQky80gE2WUz8PTbFuF8yoo/POS2lIRmD9bTQ9n3xSbhryXnl83162uc5VT7dEmrXqFC0EbIJaThwQvgj5uuxWKyqnFLloGrqOyPah6ZE6+EJUrRMitYjk6IxdlKoYaP8YCmaIdokqr3HL4rOxPekaEmJzmRKBHrHRK0WL09YrUcm3H82aF4gRcuMCFozInDwE2ARYAELWMACFrAIsIAFLGABC1gEWMACFrCABSwCLGABC1jAAhYBFrCABSxgAYsAC1jAAhawgEWABayKh1WvGfeoUeNhYAHL0yg9xkN+3fxG1e0gsIDlXWP1DN3vi1g/+qPJfySuFmAByztYUXuuMXZK+KPHFhTNbAIWsLyBpVtzbe98JVoGxoX8+69C4QJWBcJqPzotOu050XTorJCj8U81ZDwJLGB50FhT7hZ/5300HfrMaa4FVfcWF7AqFFaHbKwO+fpZXGFLrrmMRmABK29Y7vuwZtO4+pzmsq8ouvkEsICVPyyZbHP1fSrULnNBCeWPC1jAyuCaXcGlW5f9IaMBWCUOSwnFXysGrOqe/ntvBysX1w6Jyxc2/6jR4o8DC1jrgGWsCWt1c/kj9iVFM7cBqwRhbX/1Q1EbGk4pWvwjmdOFSu3+kY9rQ++NK9rItV1vfXFbWC4uO7e5rCt3MxaBtclpGTjvngHr3AkvdJr7z4kdvWfE7ne/zn4aXAvXM6Pp5pK45ms0ow5YJRTnE5lzEZ0RVPBkXsdty/W8N7e5vnMx+nTzkroBXMAid4C/gkvtMufletAPLOI
NLncsZnDp1m+qHleBRbxrrmVcXaPzijbsAxbxDNdyc8kF/S/STi2wiHe4smuu0d/lgl4BFvG2uQ6Oyeayf1a14WpgEc8W9MEMLtlcv8rmegxYxMNPi9+mcemm01yPAot4isv5zlMNWz8tj0VgEW9uRcgFfcBZ0IfNy2rUfgRYxANY6a+lmvvPCn8ksahEzW3AIvnFaSvrQgaVfU2utdoYhST/ESjbyvnVhC9i/10TMtpYvJM8m2rGHYEtA+ecTRg3FC2+m9sNJO81VTCDSo6/q6tRAYvc3UI9p6lq9sWf4isdkvf4y2mq60rIeJovoYmH4y+xJipgkXXfUuhYaaqbaige5Id+xKM11bioiySv14TiHfw0uVQu3BbdTBHMQSWbalGOvz1spiiR5G7/ai5gNrz9KxdVNHlD0Yb3sP2rJLJqw+r+kVOF3LDqbIjNbFi9eqcNq8FMi2ZO/VuS4+9ZNqyWGCx3i722lbbYz7jjsmXQbaqb8r09xxb7UoW1RQ4Fya6pBt011S1V33hTAWsLwdoKxxilb34uN1ViUdHjz3OMEbDyg5UZfzsHz4u6aFJ++ht+gYPXgJXnUZHphbqDSo6/JTmWX+SoSGDlfbhttqleObboFSpgVTIseb2XUcmm+leieonjuIGV3wMEhqbdc953vvm5c0vhlqJ5iwpYlQrr6LTY9faXwq8n/pNN9TKPPAGWBw9pSswG3jgt6rvfX5LXfh8PaQKWB7CM+2Rj/VDf/YFQC4gKWBUGa3vUftCvWylVt7sL/VrAqiBY1T3GA2rUDBTjtYBVQbCKGWABC1jAAhYBFrCABSxgAYsAC1jAAhawgEWABSxgAQtYwCLA4mIDC1jAAhYBFhccWMACFrAIsAiwvILVNjQl9h6/6OIixUpKdCZTItA7Vp6w1K5R9wzMdomr9fAEKVom5aSYFI2xk0ING+UHy6dbzjN9haKNkE1Iw4ETwh8xyw7W/5rG3+a7bM5eAAAAAElFTkSuQmCC"

 

[TooFatBoy]

J'ai toujours ça, mais pas grave.

Normalement on ne met le type de la variable que quand on la déclare, si je ne me trompe.

 

[patricktoulon]

le code de ta table est bon meme pour le base64
je viens de le tester


c'est donc bien tes librairies qui sont fracassées
tu ne peut pas te servire du xmldomdocument
là on est dans la m... pour ramener un fichier
pas étonnant j'ai lu un article qu'il commencaient a les retirer de W10 depuis juillet 2022

 

[Dudu2]

J'ai ça, ça passe mais les images sont illisibles

Function Base64tofichier(ByVal strData As String, ByVal chemin As String)    ' As Object
    Dim XmlDoc As Object, objNode As Object, a() As Byte, Buffer() As Byte, intFileNumber, i&
    Set XmlDoc = CreateObject("MSXML2.DOMDocument")
    Set objNode = XmlDoc.createElement("b64")
    Dim arrData() As Byte
   
    arrData = strData
    MsgBox UBound(arrData) - LBound(arrData) + 1 & " " & Len(strData)
   
    With objNode
        .DataType = "bin.base64"
        .nodetypedvalue = arrData
        a = .text
        Set XmlDoc = Nothing
        '///////////////////////////////////
        i = FreeFile: Open chemin For Binary As #i: Put #i, , a: Close #intFileNumber
MsgBox chemin
    End With
End Function

 

[patricktoulon]

c'est bien ce que je dis tes librairies sont en vrac
ton internet tu va pas tarder à la voir disparaitre
toute les librairies internet dans vba seront orphelines
vous etes condanés a faire des pubier ......en passant par un add sheet ou new instance d'application etc.. etc... pour chopper un code imbuvable (bourré d'erreurs qui donnera 5 à 10 résultat différents sur 10 pc )et ou l'on peut rien maitriser
le vrai bonheur quoi

c'est quoi le detail de la tienne de dlll dans le syswow

 

[Dudu2]

Non, y a un truc qui n'accepte que les Arrays de Byte et pas les String.
L'erreur de type vient de là.