Autres optimiser mon code

[patricktoulon]

Bonjour a tous
je souhaiterais optimiser mon code de "reduction de script html à l'essentiel"
c'est a dire
ma fonction converti le texte formaté d'une cellule en html propre c'est a dire qu'aucunes balise est en doublon
contrairement au .value(11)(le value en xml) qui me sort une vrai daube dans les balises data des cell

mais visiblement en vba ça a un prix; des que le texte est conséquent plus ou moins 10 lignes et plus
ça rame un peu je dirais
si il y a des pros dans le coin dans ce domaine
je suis preneur

 

[zebanx]

Bonjour Patricktoulon, le forum,

Je ne sais pas si le fil suivant pourra t'être utile mais le test de la fonction sur la première réponde (fnConvert2HTML) me parait assez rapide et te donnera peut-être des pistes utiles pour répondre à ta demande.
Ce site me parait adapté pour faire des demandes aussi exigeantes que tes besoins.
En tout en complément de E.D.

Convert Rich Text to HTML formatting tags

I'm working with an Excel list and want to turn: Quercus agrifolia var. oxyadenia (Torr.) J.T. Howell into: <i>Quercus agrifolia</i> var. <i>oxyadenia</i> (Torr.) J.T. Howel...

stackoverflow.com

A voir.
Zebanx

 

[dysorthographie]

Bonjour,
il y à déjà longtemps je t'avais proposé une méthode trouvé sur internet, mais elle te convenait pas!

Function RangetoHTML(rng As Object)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
 
    Set TempWB = rng.Application.Workbooks.Add(1)
     rng.Copy
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        .Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Bernard_XLD]

Bonjour patricktoulon, zebanx, dysorthographie, le forum

@patricktoulon , cela ne serait pas plus simple et plus rapide d'enregistrer tes cellules au format Html et d'aller lire le code créé ?

Bien cordialement, @+

 

[patricktoulon]

re
Bonsoir @zebanx @dysortographie
@zebanx je vais regarder

robert oui je m'en souvient mais le resultat est pas terrible il n'y a pas e couleur sur la table il n'y a plus rien au niveau formatage

c'est sur que là c'est rapide

avec mon webbrowser je fait aussi bien mais avec tout suf que il y a quelques nuance sur les bordures et autres petits details

ensuite
@Bernard_XLD
non le style et certain attributs son dans une balise style et col externe
c'est une vrai galère a recomposé
avec mes deux technique j'ai un code style inline comme la capture ci dessus avec mon webbrowser mais c'est pas tout a fait parfait

 

[patricktoulon]

tenez si ça vous intéresse le htmlconverter ultra rapide mais comme enregistrement en html il manque des propriétés
mais bon le résultat est sympa pour des tables simples
c'est instantané
la sub test on vois le résultat dans une page web IE et la 2d sub garde le userform ouvert avec un textbox contenant le code

 

[Bernard_XLD]

re,

non le style et certain attributs son dans une balise style et col externe
c'est une vrai galère a recomposé

normalement, tout est dans un seul fichier en format mhtml, il est disponible dans Excel.

Bien cordialement, @+

 

[patricktoulon]

oui mais le code formatage est dans des balises externe et c'est un vrai clvère a recomposer inline

j’obtiens un meilleur résultat avec un webbrows dans un userform avec execWB pour paster dans un contenteditable du document dans le webbrowser

 

[patricktoulon]

re
Bonjour à tous
bon j'ai fait une tentative avec le value(11)
j'ai un seul problème avec
dans le xml récupéré les saut de lignes ne sont pas détectés

Option Explicit
Sub récupCodeEn_D1()
    Dim code$
    [D1] = GetTextCellByhtmlmemory([A1])    'récupération du code html
End Sub

Sub Test_avec_Vue_dans_IE()
    Dim code$
    code = GetTextCellByhtmlmemory([A1])    'récupération du code html
    'visu dans une page web dans IE
    With CreateObject("internetexplorer.application")
        .Visible = True: .navigate "about:bank":
        Do While .readystate < 4: DoEvents: Loop
        .document.write code
    End With
End Sub

Function GetTextCellByhtmlmemory(cel As Range)
    Dim fonts As Object, XXmL$, EleM

    ' on fait quelque replacement pour la balise data et pour les attributs préfixé
    XXmL = Replace(Replace(Replace(cel.Value(11), "ss:Data", "Data"), " html:", " "), " x:", " ")

    With CreateObject("htmlfile")    'création object document html en memoire
        .body.innerhtml = XXmL    ' on met dans le body le code XML en vrac comme ça
        .body.innerhtml = .getelementsbytagname("Data")(0).innerhtml    'on ne garde que le innerhtml de la balise Data

        For Each EleM In .all

            'suppression des attributs si ils sont vide ou inutile et déplacement du size dans le CSS inline
            If EleM.getattribute("color") = "#000000" Then EleM.removeattribute ("color")
            If EleM.getattribute("size") <> "" Then EleM.Style.FontSize = EleM.getattribute("size") & "pt": EleM.removeattribute ("size")
            If EleM.getattribute("Family") <> "" Then EleM.removeattribute ("Family")

            'remplacement des espaces dans le innerhtml par l'espace en  html
            If EleM.tagname = "FONT" Then EleM.innerhtml = Replace(EleM.innerhtml, " ", "&nbsp;")

            'si pas d'attribut alors la balise devient un segment ou  nodetext (l’élément devient l’intérieur de lui même)
            If InStr(1, EleM.outerhtml, "<FONT>") > 0 Then EleM.outerhtml = EleM.innerhtml
        Next

        GetTextCellByhtmlmemory = .body.innerhtml
    End With
End Function

 

[dysorthographie]

Bonsoir Patrick,

Private Sub UserForm_Initialize()
WebBrowser1.Navigate ("about:blank")
WebBrowser1.Document.DesignMode = "On"
DoEvents
Range("A1").Copy
WebBrowser1.Document.ExecCommand "Paste", False, Nothing
Debug.Print WebBrowser1.Document.body.innerHTML
End Sub

 

[patricktoulon]

bonjour robert
c'est la méthode que j'utilise déjà depuis longtemps
mais moi j'utilise pas execommand mais execWB
et puis il y a quand même des différences tu le vois d'une manière dans le webbrowser mais des que tu est sur un navigateur c'est différent
et çà ne met pas le wraptext et tout plein de chose encore avec les bordures et le text aligne qui est pas bon
les dimensions sont fausses aussi pour une compatibilité et un visu égal sur n'importe quel navigateur ou app mail il faut les reprendres

Private Sub UserForm_Activate()
    Dim I&
    TextBox1 = ""
    If visibility Then
        valider.Caption = "Quiter"
        Me.Width = Table.Width * 1.2: Me.Height = Table.Height + 60
        Me.WebBrowser1.Width = Me.InsideWidth
        Me.WebBrowser1.Height = Table.Height + 10
        voir.Top = Me.InsideHeight - 20
        valider.Top = Me.InsideHeight - 20
    End If

    With WebBrowser1
        .navigate "about:blank"
        Do While .readystate < 4: DoEvents: Loop
        .document.write "<html><body style=""margin:0;width:100%;height:100%;""><div id='calque' style=""width:100%;height:100%;"" contenteditable=true></div></body></html>"
        Table.Copy
        Set div = .document.getelementbyid("calque")
        div.Focus
        .ExecWB 13, 2  '--paste. don't prompt user.



        Set dico = CreateObject("Scripting.Dictionary")
        For Each cel In Table.Cells: dico(cel.MergeArea.Address(0, 0)) = "": Next
        tMk = createTablemask(Table)

        With .document.getelementsbytagname("TABLE")(0):
            .Style.Width = Round(Table.Width) + 1 & "pt"
            .Style.Height = Round(Table.Height) - 10 & "pt"
            
            .Style.FontSize = ThisWorkbook.Styles(1).Font.Size & "pt"
            nbligne = .getelementsbytagname("TR").Length
        End With

        Set tds = .document.getelementsbytagname("TD")
        For Each EleM In dico
            With Range(EleM)
                tds(I).innerhtml = "<font>" & tds(I).innerhtml & "</font>"
                tds(I).ChildNodes(0).Style.margin = "2pt"

                VA = .VerticalAlignment: VA = Switch(VA = xlTop, "top", VA = xlBottom, "bottom", VA = xlCenter, "middle", IsNull(VA), "bottom")
                ha = .HorizontalAlignment: ha = Switch(ha = xlLeft, "left", ha = xlCenter, "center", ha = xlRight, "right", IsNull(ha), "right")

                tds(I).Style.TextAlign = IIf(IsNull(ha), "left", ha)
                tds(I).Style.verticalalign = IIf(IsNull(VA), "bottom", VA)



                If tds(I).colspan > 1 Or tds(I).rowspan > 1 Then
                    'tds(I).Style.Border = 0

                End If

                If .WrapText Then tds(I).Style.WORDBREAK = "break-all"

                    I = I + 1
            End With
        Next
        I = 0
        If OnlyText Then
            cod = div.getelementsbytagname("TD")(0).innerhtml
            Do
                If InStr(1, cod, "class=") > 0 Then cod = Replace(cod, "class=font" & I, "") Else Exit Do
                I = I + 1
            Loop
            div.innerhtml = cod
        End If

    End With
    TextBox1 = div.innerhtml

    'Debug.Print TextBox1
    If visibility = False Then Me.Hide
    'IE.ExecWB 17, 2  '-- select all. don't prompt user.
    'IE.ExecWB 12, 2  '-- copy. don't prompt user.

End Sub

 

[patricktoulon]

tiens fait la différence par toi même