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

Dudu2

XLDnaute Barbatruc
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 !).
 

Pièces jointes

  • Classeur1.xlsm
    261.1 KB · Affichages: 11

Dudu2

XLDnaute Barbatruc
Pas de souci on n'est pas pressé. Difficile de coder à 2, je te laisse ramer seul. Si tu peux bine séparer comme tu l'avais fait la construction de la table et l'insertion des image.
Ce qui prend du temps c'est la création des images soit par Archive soit par Publish, mais on n'y coupe pas
 

Dudu2

XLDnaute Barbatruc
Sinon, Publish est perdu quand on coupe un Tableau Structuré ou quand les derniers TD son vides.
En fait c'est le copy / paste du range qui ne prend pas la sous-partie d'une tableau structuré en tant que tel.
Un tableau structuré le restera en copy / paste que s'il est copié dans son ensemble.
Je vais faire un code qui compense ce problème et je te le passe car tu as le même problème à la base me semble-t-il. Sauf à traiter le Range directement dans sa feuille d'origine.
 

patricktoulon

XLDnaute Barbatruc
Bonjour @Dudu2
une fonction image en string
ca encore ca sera pas bien difficile il suffit de prendre une trame d'une shapes faite dans un code de l'a ménager et de faire des replaces
c'est plus la construction de la table qui est compliqué en string son écriture est linéaire donc les imbrications sont exclues du principe

comme tu l'a vu dans l'exemple que je t'ai donné la construction de base avec fusion est faite
je fait les arrangement bordure maintenant

réponse au #437
la copie séparée si TS là ça va être coton
 

Dudu2

XLDnaute Barbatruc
La gestion des Tableaux Structurés à récupérer puis ajuster sur le Range est EXTÊMEMENT complexe du fait qu'on ne peut pas supprimer les lignes de la feuille comme on veut à cause des lignes titres et autres combinaisons.
Je comprends pourquoi Publish ne le fait pas. C'est possible de le faire mais je ne vais pas perdre de temps pour ça, d'autant que pour tester c'est infernal vu le nombre de situations différentes avec de multiples Tableaux Structurés aux marges du Range.

Si tu récupères les cellules et leurs formats directement dans le Range d'origine, tout ça n'est pas nécessaire.
 

patricktoulon

XLDnaute Barbatruc
Bonsoir @Dudu2 ma version string me titille un peu les nerfs
pourrais tu y jeter un œil sur le background color quand j'active cette partie ca deraille c'est dommage j'en suis à 0.047 millièmes de seconde pour faire la table
VB:
'***************************************************
'ebauche patricktoulon '/2022
' createhtml code table  en string

Const TD As String = "<TD id='"
Const TR As String = "<TR id=>"


Sub test()
    Dim tim
    tim = Timer
    CreateStringHtmlCodeByString [c4:i13]

    MsgBox Format(Timer - tim, "#0.000 Sec") & " pour obtenir le codehtml"
End Sub

Function CreateStringHtmlCodeByString(rng As Range)
    Dim cel As Range
    For lig = 1 To rng.Rows.Count
        code = code & Replace(TR, "id=", "id='Ligne" & rng.Rows(lig).Row & "'") & vbCrLf
        For c = 1 To rng.Columns.Count
            Set cel = rng.Rows(lig).Cells(c).MergeArea: addr = cel.Address(0, 0)
            If InStr(1, code, addr) = 0 Then
                code = code & Replace(TD, "id='", "id='" & Trim(addr) & "'")
                If cel.Columns.Count > 1 Then code = code & "colSpan= " & cel.Columns.Count & " "
                If cel.Rows.Count > 1 Then code = code & " rowSpan= " & cel.Rows.Count & " "
                code = code & " style="""
                code = code & "width:" & Replace(cel.Width, ",", ".") & "pt;"
                code = code & "height:" & Replace(cel.Height / 1.5, ",", ".") & "pt;"
                If cel.Cells(1).Font.Size <> 11 Then code = code & "font-size:" & Replace(cel.Font.Size - 1, ",", ".") & "pt;"
                If cel.Cells(1).Font.Name <> "Calibri" Then code = code & "font-family:" & cel.Font.Name & ";"



                '///////////////////////////////////////////////////////////////////////////////////////////
                'cette partie me genere un desordre si je l'active
                'On Error Resume Next   'le backgraound (Attention!!! 'displayformat(version sup à 2007)
                'cir = xlToHtmlColor(cel.Cells(1).DisplayFormat.Interior.Color)
                'If Err.Number > 0 Then Err.Clear: cir = xlToHtmlColor(cel.Cells(1).Interior.Color)
                'On Error GoTo 0
                'If cir <> "#FFFFFF" Then code = code & "background-color:" & cir & ";"
                '//////////////////////////////////////////////////////////////////////////////////////////

                'celle là est bonne mais ne pends pas en charge les (TS)
                cir = xlToHtmlColor(cel.Cells(1).Interior.Color)
                If cir <> "#FFFFFF" Then code = code & "background-color:" & cir & ";"

                'et je pige pas pourquoi




                '**************************************************************************
                'l'epaisseur des bordures
                'bordure weigth  ; dans l'ordre (top right bottom left)

                tp = cel.Borders(8).Weight: tp = IIf(tp > 1, tp - 1, tp) & "px "
                r = cel.Borders(10).Weight: r = IIf(r > 1, r - 1, r) & "px "
                bt = cel.Borders(9).Weight: bt = IIf(bt > 1, bt - 1, bt) & "px "
                lt = cel.Borders(7).Weight: lt = IIf(lt > 1, lt - 1, lt) & "px;"

                Dim Cl As Range, celr As Range, celB As Range
                Set celr = cel.Offset(, 1).Resize(cel.Rows.Count)
                For Each Cl In celr.Cells
                    If (Cl.Borders(7).Color <> cel.Borders(10).Color) Then r = "0px "
                Next

                Set celB = cel.Offset(1).Resize(cel.Columns.Count)
                For Each Cl In celB.Cells
                    If (Cl.Borders(8).Color <> cel.Borders(9).Color) Then bt = "0px "
                Next

                code = code & "border-width:" & tp & r & bt & lt
                '**************************************************************************



                'bordure couleur  ; dans l'ordre (top right bottom left)
                code = code & "border-color:" & _
                       xlTohtmlBorderColor(cel.Borders(8)) & " " & xlTohtmlBorderColor(cel.Borders(10)) & " " & _
                       xlTohtmlBorderColor(cel.Borders(9)) & " " & xlTohtmlBorderColor(cel.Borders(7)) & ";"

                'bordure style  ; dans l'ordre (top right bottom left)
                code = code & "border-style:" & _
                       ConvertBorderStyle(cel.Borders(8)) & " " & ConvertBorderStyle(cel.Borders(10)) & " " & _
                       ConvertBorderStyle(cel.Borders(9)) & " " & ConvertBorderStyle(cel.Borders(7)) & ";"

                ha = cel.Cells(1).HorizontalAlignment
                If ha = xlCenter Then code = code & "text-align:center;"
                If ha = xlRight Then code = code & "text-align:right;"
                If IsNull(ha) Then code = code & "text-align:left;"

                va = cel.Cells(1).HorizontalAlignment
                If va = xlCenter Then code = code & "valign:middle;"
                If va = xlRight Then code = code & "valign:bottom;"
                If IsNull(va) Then code = code & "valign:top;"


                code = code & """>"
                'ici on met le innerhtml
                code = code & "<font style='margin-top:0;'>&nbsp;" & cel(1) & "</font>"
                code = code & "</TD>" & vbCrLf
            End If
        Next c
        code = code & "</TR>" & vbCrLf
    Next lig
    code = Replace(code, "-4138", "1")
    styletable = "style=""BORDER-COLLAPSE: cghghgollapse; TABLE-LAYOUT: fixed;" & _
                 "font-size:10pt;font-family:calibri;Max-width:" & Replace(rng.Width, ",", ".") & "pt;" & _
                 "max-height:" & rng.Height / 1.5 & "pt;"""
    code = "<table " & styletable & ">" & code & "</table>"
    Fhtml = ThisWorkbook.Path & "\TestEnString.htm"
    X = FreeFile: Open Fhtml For Output As #X: Print #X, code: Close #X

    CreateStringHtmlCodeByString = code
End Function
Function xlTohtmlBorderColor(bs As Border)
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
    Dim str0 As String, strf As String, couleur As String

    couleur = bs.Color
    If bs.LineStyle = xlNone Then couleur = RGB(220, 220, 220)
    str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    xlTohtmlBorderColor = "#" & strf & ""
End Function
Function xlToHtmlColor(couleur)
'collection fonction perso
'fonction Color XL to HTMLCOLOR ---> By Patricktoulon (2016)
    Dim str0 As String, strf As String
    str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    xlToHtmlColor = "#" & strf & ""

End Function
Function ConvertBorderStyle(b As Border)
'Fonction de convertion du style de bordure
'Patricktoulon (2016)
'xlContinuous= 1  / 'xlDash= -4115  / 'xlDashDot= 4  / 'xlDashDotDot= 5  / 'xlDot= -4118 / 'xlDouble= -4119 / 'xlLineStyleNone= -4142 / 'xlSlantDashDot = 13
    Dim bds
    bs = b.LineStyle
    bds = Switch(bs = xlNone, "solid", bs = xlLineStyleNone, "solid", bs = xlContinuous, "solid", bs = xlDot, "dotted", bs = xlDash, "dashed", _
                 bs = xlDashDot, "dashed", bs = xlDouble, "double", bs = xlDashDotDot, "dashed", bs = xlSlantDashDot, "dashed")
    ConvertBorderStyle = bds
End Function

'****************************************************************************************************
Sub testqq()
    MsgBox htmltexte([c9])
End Sub


Function htmltexte(cel As Range)
    Debug.Print cel(1).Value(11)
    'Fonction de récupération du code html du texte formaté dans la cellule
    'Version sans htmldocument (STRING)
    'Patricktoulon (2016)
    Dim cde$, elem, t
    cde = Replace(Replace(cel.Value(11), "ss:", ""), "html:", "")
    t = Split(cde, "<Cell ")
    If UBound(t) > 0 Then
        cde = Replace(cde, Split(t(0), "<Font")(0), "")
        cde = Split(cde, "</Data")(0)
        htmltexte = cde
    Else
        htmltexte = cel.Value
    End If
End Function
 

Dudu2

XLDnaute Barbatruc
J'ai une ComboBox 3 colonnes. Je valorise sa .List mais seule la 1ère valeur s'affiche.
Ça m'énerve ! Tu peux m'aider ?
1664390251217.png
 

patricktoulon

XLDnaute Barbatruc
alors tu a trouvé pour mon code
car là moi je sèche

et pour ton problème de combo en fait c'est le fait de pouvoir mettre plusieurs colonne qui est une erreur de conception MS je dirais

il est si facile de faire une bricole pour rendre une listbox developpable et undeveloppable
 

Dudu2

XLDnaute Barbatruc
il est si facile de faire une bricole pour rendre une listbox developpable et undeveloppable
Ah bon ? Comment ?

alors tu a trouvé pour mon code
Pas eu le temps de regarder, j'ai bossé pour cette fille (je suppose) avec sa galère de saisie en lui faisant un formulaire. Je sais pas (encore) si ça va lui faciliter la vie ou pas !
 

Discussions similaires