Autres optimiser mon code

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

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

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

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