Discussion :

[Invité]

Non j'avais tu texte;quelques bordure, fondcolor ,textecolor et je trouvais bien la feuille de style xml!

[pijaku]

De toutes façons, rien n'est encore achevé.
Mais je crois savoir pourquoi.
Je testerai et tiendrais informé.
Bon week end

[patricktoulon]

re
en effet
la construction de la tablehtml sur la base du xml s'avère compliqué car certaines cellules vides n'y sont même pas dans le xml

alors quand c'est la dernière c'est pas compliqué a remédier(on ajoute autant de cell sur la ligne que de columns.count

mais si elle est au milieu d'une ligne et donc les suivantes décalées

a corriger la c'est Cotton je cherche le moyen

purée j'ai encore trouvé un truc tordu moi hein

EDIT:
bon pour le moment je fait comme ca pour la construction
je fait simplement un replace global sur les cells empty avant de tabler en html
chaque cel en XML est syncronisée avec plage.cells(lig+1,col)
ce qui me permet en cas d'attribut "datetime" de remplacer innerh par plage.cells(lig+1,col).text

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
Option Explicit
Sub test()
    Dim plage As Range, doc As Object
    Set plage = Range("A1:D5")
    Set doc = createbasehtml(plage)
    Debug.Print doc.BODY.innerhtml
End Sub
Function createbasehtml(plage As Range) As Object
    Dim docxml As New MSXML2.DOMDocument
    Dim Dochtml As Object, Noeuds2 As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Balise As IXMLDOMNode, Element As IXMLDOMElement, fonte, idcel, innerh$, lig#, col#, TR, TD, Corp, Fonts, i#, fdate, transdate$
    'ici il faudrais peut etre stoquer les formules dans une boucle avant de replacer
    plage.Replace What:=Empty, Replacement:="-", SearchOrder:=xlByColumns, MatchCase:=True
    Set Dochtml = CreateObject("htmlfile")
    Dochtml.BODY.innerhtml = "<TABLE><TBODY></TBODY></TABLE>"
    Set Corp = Dochtml.getelementsbytagname("tbody")(0)
    Corp.Parentelement.classname = Replace(Replace(plage.Address, "$", ""), ":", "-")
    With docxml
        If Not .LoadXML(Replace(plage.Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data")) Then Err.Raise .parseError.ErrorCode, , .parseError.reason
        'Debug.Print .XML
        Set Noeuds2 = docxml.getelementsbytagname("Row")
        For lig = 0 To Noeuds2.Length - 1
            Set TR = Dochtml.createElement("TR"):
            Corp.appendChild (TR)
            'Debug.Print Noeuds2(i).XML
            Set SubNoeuds = Noeuds2(lig).ChildNodes
            col = 0
            For Each Balise In SubNoeuds
                col = col + 1
                TR.classname = "ligne" & lig + 1 & "  roww:" & plage.Cells(lig + 1, col).Row
                Set Element = Balise
               ' Debug.Print Balise.XML
                Set TD = Dochtml.createElement("TD"):
                 idcel = Element.getAttribute("ss:StyleID")
                If Not IsNull(idcel) Then TD.ID = idcel Else TD.ID = "Defaut"
                Set Element = Balise.ChildNodes(0)
                fdate = Element.getAttribute("ss:Type")    'DateTime"
 
                If fdate = "DateTime" Then transdate = plage.Cells(lig + 1, col).Text
 
 
 
                    'If Balise.ChildNodes.Length > 0 Then
                        innerh = Balise.ChildNodes(0).XML
                        innerh = Split(Split(innerh, Split(innerh, ">")(0) & ">")(1), "</Data>")(0)
                        innerh = Replace(Replace(innerh, "xmlns:html=""http://www.w3.org/TR/REC-html40", ""), "html:", "")
                        innerh = Replace(innerh, "xmlns:x=""urn:schemas-microsoft-com:office:excel""", "")
                        'Debug.Print innerh
                        If innerh = "-" Then innerh = ""
                        ' Debug.Print innerh
                        If transdate <> "" Then innerh = transdate: transdate = ""
                        TD.innerhtml = "<FONT>" & innerh & "</FONT>"
                    'End If
 
                Set Fonts = TD.getelementsbytagname("FONT")
                For i = 0 To Fonts.Length - 1
                    If Fonts(i).Size <> "" Then Fonts(i).Style.FontSize = Fonts(i).Size & "pt": Fonts(i).Size = 0
                Next
                TR.appendChild (TD)
            Next
        Next
    End With
   plage.Replace What:="-", Replacement:="", SearchOrder:=xlByColumns, MatchCase:=True
 Set Noeuds2 = Nothing
    Set Element = Nothing
    Set SubNoeuds = Nothing
    Set Balise = Nothing
    Set createbasehtml = Dochtml
    'on replace les "-" pour les remettre vide ou remettre les formuiles si elles ont été stoquées
 
End Function

je sais pas ce que tu en pense mais en tout cas merci pijaku



edit:




juste pour le fun je la montre
il est de notoriété public qu'avec l'object htmldocument je fait mémé mon petit dejauné

je te propose donc (en esperant que tu monte pas au plafond considérants que l'on est un peu en dehors de la déontologie) d'examiner le XML DANS UN DOCUMENT HTMLC'EST ASSEZ SIMPLE EN FAIT

tout d'abords il faut savoir que si la plage n'est pas rempli jusque en bas( des lignes vides a la fin ) le xml applique le .end(xlup).

on perd donc des cellulesdu bas et c'est pareil que pour les cellules vide et aucun style au milieu la plage

j'ai d'abords pensé a mettre 1 caractères provisoire dans les cellules vides (mais en cas de formule elles sont perdues a moins de les mémoriser ce qui veut dire moulin a gogo

mais ensuite comme j'ai remarqué qu'une cellule vide avec une propriété autre que xlnone( bordure/interior, font,etc...) était prise en compte alors je fait simplement un interior.color avec une couleur presque blanche et hop c'est bon on a toutes les cellules dans le xml et le end (xlup) appliqué par le XML ne l'ai plus et je ne perd rien en ce qui concerne les cellules (formule, propriétés, MFC ,etc...)

démonstration de la création du code html de la table dans un document html encodé en XML( c'est rigolo)

si ca c'est pas du html nikel je mange mon clavier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
 
Option Explicit
Sub test()
    With CreateObject("htmlfile")
        Dim plage As Range, doc As Object, TBODY, TR, MesTR, TD, MesTD, pre, cel, code$, lig#, col#, att
        Set plage = Range("A1:d10")
        '****************************************************************************************
        'on met une couleur temporaire(presque blanc pratiquement invisible a l'oeuil nu) au cellule vides pour qu'elles soit prises en compte dans le xml
        For Each cel In plage.Cells
            If cel.Value = "" Then cel.Interior.Color = RGB(254, 254, 254)
        Next
        '******************************************************************************************
        'je replace simplement l'appelation xml par l'appelation html des lignes,cellule et le data se transforme en font
        code = Replace(plage.Value(xlRangeValueXMLSpreadsheet), "ss:", "")
        code = Replace(Replace(Replace(Replace(code, "<Row", "<TR"), "Row>", "TR>"), "<Cell", "<TD"), "Cell>", "TD>")
        code = Replace(Replace(Replace(code, "<Data", "<pre"), "Data>", "pre>"), "html:", "")
        'Debug.Print code
        'j'injecte le code xml/html tel quel avec la transformation et je rajoute une table vide
        .body.innerhtml = code & "<table><tbody></tbody></table>"
        Set TBODY = .getelementsbytagname("TABLE")(1).Children(0)
        'je recupere les ligne de la table(0)la xml transformée pour recréer les element dans la table(1)
        ' en leur attribuant leur innerhtml,id et autre attribut correspondant en html (ce que je veux garder et de premier ordre )si necessaire
        Set MesTR = .getelementsbytagname("tr")
        For lig = 0 To MesTR.Length - 1
            Set TR = .createElement("TR")
            TBODY.appendChild (TR)
            Set MesTD = MesTR(lig).getelementsbytagname("TD")
            For col = 0 To MesTD.Length - 1
                Set TD = .createElement("TD")
                Set pre = MesTD(col).getelementsbytagname("PRE")
                If pre.Length > 0 Then TD.innerhtml = MesTD(col).getelementsbytagname("PRE")(0).innerhtml
                If Trim(TD.innertext = "") Then TD.innerhtml = "" Else TD.innerhtml = "<FONT>" & TD.innerhtml & "</FONT>"
                TR.appendChild (TD)
                att = MesTD(col).getAttribute("MergeDown"): If Not IsNull(att) Then TD.rowspan = Val(att) + 1
                att = MesTD(col).getAttribute("MergeAcross"): If Not IsNull(att) Then TD.colspan = Val(att) + 1
                If MesTD(col).Children.Length > 0 Then att = MesTD(col).Children(0).getAttribute("Type")
                If att = "DateTime" Then TD.innerhtml = "<FONT>" & Cells(lig + 1, col + 1).Text & "</FONT>"
                att = MesTD(col).getAttribute("styleID")
                TD.ID = "defaut": If Not IsNull(att) And TD.innertext <> "" Then TD.ID = att
            Next
        Next
        .body.innerhtml = Replace(.getelementsbytagname("TABLE")(1).outerhtml, "size=+0", "") ' un petit netoyage de coquille
        ' affiche le code outerhtml  de la table finalisée
        Debug.Print .body.innerhtml
    End With
    ' on enleve la couleur temporaire que l'on a mis pour prendre en compte les cellules vides
    For Each cel In plage.Cells
        If cel.Value = "" Then cel.Interior.Color = xlNone
    Next
End Sub

[pijaku]

Patrick,

Deux choses...

1- ton histoire de mettre des cellules "presque blanches" ne sert à rien. Rien du tout. On en reviens à ce que je t'ai dis deux fois, le repérage de la première cellule de la plage.
Soit Plage.Cells(1, 1) n'a ni valeur, ni style, auquel cas, il faut lui en appliquer un invisible :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Plage.Cells(1, 1).Interior.Color = xlNone

ce code suffit à faire apparaitre ceci dans le code xml :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
<Style ss:ID="s62">
    <Interior/>
</Style>

2- Le langage html est un langage "statique".
Est ce que, dans l'utilisation de ce que tu souhaites faire, tu pourras modifier les cellules?

[patricktoulon]

Bonjour pijaku
oui dynamiquement en javascript dans le document un div conteneditable est ajouté dans le td et le contenu dans le le TD passe dans le div et vis et versa pour l'enregistrement

en mode écriture div dynamique avec addeventlistener en enregistrement (statique) le div est supprimé et son contenu est transféré directement dans le td mais ca c'est un autre sujet

pour l'histoire de ta cells (1,1) ca le fait pas chez moi si je la clear par exemple ca change rien les cellules vides au milieu n'y sont pas ainsi que les dernières et qui sont vides

[pijaku]

Je te montrerai comment, mais pas ce week end, contrer ce problème de cellules vides.
Bon week.

[pijaku]

Bonjour,

Voici le code presque complet. il te sort deux fichiers : test.css et test.html

Il te reste à peaufiner et trois points qui sont indiqués "RESTE A FAIRE" dans les commentaires :

1. CSS : LineStyle
2. CSS : Weight
3. HTML : Data

La fonction No_Style_No_Value teste la première cellule de la plage. Si pas de style, on applique : Plage.Cells(1, 1).Interior.Color = xlNone

Les fonctions AddTD et AddTR ajoutent des TD (en fonction du nombre de colonnes Attribut "ss:ExpandedColumnCount" de la Table) et des TR (en fonction des indexs des Row)...

Bon courage, il y a du boulot...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
Option Explicit
 
Private Css() As String, Html() As String
Dim Cpt As Long, NbLignes As Long
 
'**********----------**********----------** *** **----------**********--------
Private Const DEFAULTFONT As String = "Times New Roman"             'A ADAPTER
Private Const REP As String = "C:\Users\pijaku\Desktop\"     'A ADAPTER
'**********----------**********----------** *** **----------**********--------
 
Public Sub Test()
Dim MyXml As MSXML2.DOMDocument
Dim Plage As Range
Dim num As Long, i As Long
 
    Set Plage = ThisWorkbook.ActiveSheet.Range("A1:Z61")
 
    If No_Style_No_Value(Plage) Then Plage.Cells(1, 1).Interior.Color = xlNone
 
    Set MyXml = Create_Doc_Xml(Plage)
 
    Call Initialise(MyXml)
 
    num = FreeFile
    Open REP & "Test.css" For Output As #num
        For i = LBound(Css) To UBound(Css)
            Print #1, Css(i)
        Next i
    Close #num
    Erase Css
 
    num = FreeFile
    Open REP & "Test.html" For Output As #num
        For i = LBound(Html) To UBound(Html)
            Print #1, Html(i)
        Next i
    Close #num
    Erase Html
End Sub
 
Private Function No_Style_No_Value(P As Range) As Boolean
Dim xXml As New MSXML2.DOMDocument, Noeuds As MSXML2.IXMLDOMNode, SubNoeuds As MSXML2.IXMLDOMNodeList
'Test si la première cellule de la plage a, au moins, un style ou une valeur
    Set xXml = Create_Doc_Xml(P.Cells(1, 1))
    Set Noeuds = xXml.SelectSingleNode("/Workbook/Worksheet/Table")
    Set SubNoeuds = Noeuds.ChildNodes
    No_Style_No_Value = (SubNoeuds.Length = 0)
    Set xXml = Nothing: Set Noeuds = Nothing: Set SubNoeuds = Nothing
End Function
 
Private Function Create_Doc_Xml(Plage As Range) As MSXML2.DOMDocument
Dim Doc As New MSXML2.DOMDocument
    If Not Doc.LoadXML(Plage.Value(xlRangeValueXMLSpreadsheet)) Then
        Err.Raise Doc.parseError.ErrorCode, , Doc.parseError.reason
    End If
    Set Create_Doc_Xml = Doc
End Function
 
Private Sub Initialise(docxml As MSXML2.DOMDocument)
Dim Noeud As IXMLDOMNode, Tabl As IXMLDOMNode
 
    With docxml
        Cpt = -1
        Set Noeud = .SelectSingleNode("/Workbook/Styles")
        Call CreateCss(Noeud)
 
        Cpt = 1
        Set Noeud = .SelectSingleNode("/Workbook/Worksheet/Table")
        ReDim Preserve Html(Cpt)
        Html(Cpt - 1) = "<TABLE id=""Default"">"
        Html(Cpt) = "<TBODY>"
 
        Call CreateHtml(Noeud)
 
        Cpt = Cpt + 2
        ReDim Preserve Html(Cpt)
        Html(Cpt - 1) = "</TBODY>"
        Html(Cpt) = "</TABLE>"
    End With
    Set Noeud = Nothing
    Set Tabl = Nothing
    Set docxml = Nothing
End Sub
 
'**********----------**********----------** CSS **----------**********----------**********
Private Sub CreateCss(Styles As MSXML2.IXMLDOMNode)
Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
Dim Balise As IXMLDOMNode
Dim Element As IXMLDOMElement
Dim i As Long
 
    Set Noeuds = Styles.SelectNodes("Style")
    For i = 0 To Noeuds.Length - 1
        Set Element = Noeuds(i)
        Cpt = Cpt + 1
        ReDim Preserve Css(Cpt)
        Css(Cpt) = "#" & Element.getAttribute("ss:ID") & " {"
        Set SubNoeuds = Noeuds(i).ChildNodes
        For Each Balise In SubNoeuds
            Select Case Balise.BaseName
                Case "Borders": Call AddBordersStyleToCss(Balise)
                Case "Alignment", "Font", "Interior": Call AddStyleToCss(Balise)
            End Select
        Next
        Cpt = Cpt + 1
        ReDim Preserve Css(Cpt)
        Css(Cpt) = "}"
    Next
    Set Noeuds = Nothing
    Set Element = Nothing
    Set SubNoeuds = Nothing
    Set Balise = Nothing
End Sub
 
Private Sub AddBordersStyleToCss(Baliz As IXMLDOMNode)
Dim SubNoeuds As MSXML2.IXMLDOMNode
'cas particulier des bordures : le noeud <Borders> contient des SubNodes <Border>
    For Each SubNoeuds In Baliz.ChildNodes
        Call AddStyleToCss(SubNoeuds)
    Next
    Set SubNoeuds = Nothing
End Sub
 
Private Sub AddStyleToCss(Baliz As IXMLDOMNode)
'Sub de conversion xml en css : code pourri, mais fonctionnel
Dim Attribut As IXMLDOMAttribute, Nom As String, Valeur As String
Dim Element As IXMLDOMElement, ValLine As String, ValWeight As String, ValColor As String
 
    For Each Attribut In Baliz.Attributes
        Nom = vbNullString
        Select Case Baliz.BaseName
            Case "Border"
                If Attribut.BaseName = "Position" Then
                    Set Element = Baliz
                    ValLine = "" 'Element.getAttribute("ss:LineStyle")                  '        RESTE A FAIRE
                    ValWeight = "" 'Element.getAttribute("ss:Weight") & "px"            '        RESTE A FAIRE
                    If Baliz.Attributes.Length > 3 Then ValColor = Element.getAttribute("ss:Color")
                    Nom = "border-" & Attribut.Value
                    Valeur = ValLine & " " & ValWeight & " " & ValColor
                End If
 
            Case "Alignment"
                Valeur = IIf(Attribut.Value = "Center", "middle", Attribut.Value)
                If Attribut.nodeName Like "*Horizontal*" Then
                    Nom = "text-align"
                ElseIf Attribut.nodeName Like "*Vertical*" Then
                    Nom = "vertical-align"
                End If
 
            Case "Font"
                Select Case Attribut.BaseName
                    Case "FontName": Nom = "font-family": Valeur = Attribut.Value & ", " & DEFAULTFONT
                    Case "Size": Nom = "font-size": Valeur = Attribut.Value & "px"
                    Case "Color": Nom = "font-color": Valeur = Attribut.Value
                    Case "Bold": Nom = "font-weight": Valeur = "Bold"
                    Case "Italic": Nom = "font-style": Valeur = "italic"
                    Case "Underline": Nom = "text-decoration": Valeur = "underline"
                End Select
 
            Case "Interior"
                If Attribut.BaseName = "Color" Then Nom = "color": Valeur = Attribut.Value
        End Select
        If Nom <> vbNullString Then
            Cpt = Cpt + 1
            ReDim Preserve Css(Cpt)
            Css(Cpt) = Nom & ": " & Valeur & ";"
        End If
    Next
End Sub
 
'**********----------**********----------** HTML **----------**********----------**********
Private Sub CreateHtml(Table As MSXML2.IXMLDOMNode)
Dim Noeuds As MSXML2.IXMLDOMNode, SubNoeuds As MSXML2.IXMLDOMNode
Dim Attribut As IXMLDOMAttribute, Element As IXMLDOMElement
Dim BoolIndex As Boolean, NbColonnes As Long
 
    Set Element = Table
    NbLignes = 1
    NbColonnes = Element.getAttribute("ss:ExpandedColumnCount")
    For Each Noeuds In Table.ChildNodes
        BoolIndex = False
        For Each Attribut In Noeuds.Attributes
            If Attribut.nodeName Like "*Index*" Then
                AddTR Noeuds, NbColonnes, Attribut.Value
                BoolIndex = True
                Exit For
            End If
        Next
        If Not BoolIndex Then AddTR Noeuds, NbColonnes, 1
        For Each SubNoeuds In Noeuds.ChildNodes
            BoolIndex = False
            For Each Attribut In SubNoeuds.Attributes
                If Attribut.nodeName Like "*Index*" Then
                    AddTD SubNoeuds, NbColonnes, Attribut.Value
                    BoolIndex = True
                    Exit For
                End If
            Next
            If Not BoolIndex Then AddTD SubNoeuds, NbColonnes, 1
        Next
        Cpt = Cpt + 1
        ReDim Preserve Html(Cpt)
        Html(Cpt) = "</TR>"
    Next Noeuds
End Sub
 
Private Sub AddTR(Noeuds As MSXML2.IXMLDOMNode, NbCol As Long, Nombre As Long)
Dim i As Long, Element As IXMLDOMElement
 
    Set Element = Noeuds
    For i = NbLignes To Nombre
        NbLignes = NbLignes + 1
        Cpt = Cpt + 1
        ReDim Preserve Html(Cpt)
        If i = Nombre Then
            Html(Cpt) = "<TR>"
        Else
            Html(Cpt) = "<TR>"
            AddTD Noeuds, NbCol, NbCol + 1
            NbLignes = NbLignes + 1
            Cpt = Cpt + 1
            ReDim Preserve Html(Cpt)
            Html(Cpt) = "</TR>"
        End If
    Next
End Sub
 
Private Sub AddTD(Noeuds As MSXML2.IXMLDOMNode, Nombre As Long, Index As Long)
Dim i As Long, Element As IXMLDOMElement
 
    Set Element = Noeuds
    For i = 1 To Nombre
        Cpt = Cpt + 1
        ReDim Preserve Html(Cpt)
        If i = Index Then
            'ici on a un style à appliquer
            'RESTE A FAIRE : si Attribute DATA                                              '        RESTE A FAIRE
            Html(Cpt) = "<TD id=" & """" & Element.getAttribute("ss:StyleID") & """>" & Noeuds.Text & "</TD>"
        Else
            'ici on ajoute simplement une balise <TD>
            Html(Cpt) = "<TD></TD>"
        End If
    Next
End Sub

[patricktoulon]

re
Bonjour pijaku t'a bien bossé
j'en étais sur que tu allais taper avec l'attribut index des (row/Cell) ca fait mouliner quand même non?

hier j'ai suivi une autre piste qui consiste juste a ajouter un commentaire vide provisoire dans la cellule , elle est alors prise en compte et le data se retrouve avec un children"<Coment>"
je vais potasser cela ce soir en rentrant

merci

[patricktoulon]

en attendant avec le interior color ca fonctionne très bien et ca ne met pas en péril

les formule, les MFC(j'ai testé),

et le moulin consiste simplement a faire une simple boucle en avant et une autre en arrière

il faut pas oublier que le code CSS est inline pour une transportabilité totale (pas de fichier ".css")( tout dans le même fichier

pour la fonction de style je galère un peu avec les bordures "border" sont des subsub enfants
code la création de la table


pour le reste il faut absolument que dans la boucle la plage.cell(i,c) corresponde a la balise cell dans la boucle car après je changerait les id pour classe et mettrais en id l'adresse même des cellules ( c'est pour les fonctions javascript( qui remplacent formules excel basique) qui elle sont déjà écrites et les arguments qui se promènent entres elle sont les adresses de cellules

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub test()
 
je recupere le xml dans la sub pour l'injecter dans la création html et la style 
 Dim plage As Range, XXML,cel
    Set plage = Range("a1:f10")
     'si elle est xlnone  le interior.color en lecture donne "BLANC" 
     'exemple 
 'msgbox cells(1,1).interior.color & vbcrlf & vbwhite
 
    For Each cel In plage.Cells
        If cel.Value = "" And cel.Interior.Color <> vbWhite Then cel.Interior.Color = vbWhite
    Next
 
    XXML = plage.Value(xlRangeValueXMLSpreadsheet)
    Debug.Print createhtmlbyxml(plage, XXML)' creation du code html base table
    'Debug.Print CreateCss2(plage, XXML) ' creation du code style CSS' pas fini 
   For Each cel In plage.Cells
        If cel.Value = "" And cel.Interior.Color = vbWhite Then cel.Interior.Color = xlNone 
    Next
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Function createhtmlbyxml(plage As Range, XXML) As String
 
    Dim docxml As New MSXML2.DOMDocument, dochtml As Object
    Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Cellules As IXMLDOMNode, Element As IXMLDOMElement, Celchilds As MSXML2.IXMLDOMNodeList, valeurhtml
    Dim i As Long, TR, TD, TABLE, TBODY, z$, ppx#, cel
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    Set dochtml = CreateObject("htmlfile")
    dochtml.body.innerhtml = "<TABLE><TBODY></TBODY></TABLE>"
    Set TBODY = dochtml.getElementsByTagName("TBODY")(0)
    With dochtml.getElementsByTagName("TABLE")(0)
        .Style.bordercollapse = "collapse"
        .cellspacing = 0
        .Style.Width = plage.Width * ppx
    End With
    With docxml
        If Not .LoadXML(Replace(XXML, "ss:Data", "Data")) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Row")
        For i = 0 To Noeuds.Length - 1
 
            Set TR = dochtml.createelement("TR")
            TBODY.appendchild (TR)
            Set SubNoeuds = Noeuds(i).ChildNodes
            For Each Cellules In SubNoeuds
                Set Element = Cellules: c = c + 1
                Set cel = plage.Cells(i + 1, c)
                Set TD = dochtml.createelement("TD")
                TD.iD = Element.getAttribute("ss:StyleID")
                Set Celchild = Cellules.ChildNodes
                If Celchild.Length > 0 Then
                    z = Split(Celchild(0).XML, ">")(0)
                    TD.innerhtml = Split(Split(Celchild(0).XML, z & ">")(1), "</Data>")(0)
                End If
                If TD.iD = "null" Then TD.iD = "Default"
                TD.Style.Height = plage.Cells(i + 1, c).Height * ppx
                TD.Style.Width = plage.Cells(i + 1, c).Width * ppx
                TR.appendchild (TD)
            Next
 
        Next
    End With
    createhtmlbyxml = dochtml.body.innerhtml
End Function

merci encore grâce a toi j'arrive un peu a comprendre le xml et ses constantes et ces nuances
notement (IXMLDOMNode,IXMLDOMElement) et ses propriétés ,c'est bien moins compliqué avec leur homologue en html

j'ai pas fait de test avec un timer mais tu me diras si ma version mange plus

en tout cas on mouline moins qu'avec mes versions antérieures
et je profite en meme temps d'avoir les propriétés en html directement ce qui supprime le besoins de mes fonction (excelcolortohtmlX,border to css,valeur to innerhtml ,etc.....)

je suis donc gagnant

[pijaku]

Bonjour,

Il y a tout pile 1 seconde d'écart entre nos deux versions sur un plage A1:Z61 avec pleins de styles.
La tienne 1,24 s la mienne 0.35.
Mais la mienne n'est pas achevée. Il y a encore du boulot...

Mais bon, le principal est que tu as ta fonction...

[patricktoulon]

re
oui en même temps j'apprends la manip des xml ( je ne m'y était pas trop intéressé en VBA jusqu'à maintenant )

attention tout dememe
exemple ceci ne donne pas la meme choise qu'avec les propriété prises dans le xml et cette formule est plus juste en terme de dimensions ( tout n'est pas bon a prendre dans le xml)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
TD.Style.Height = plage.Cells(i + 1, c).Height * ppx
                TD.Style.Width = plage.Cells(i + 1, c).Width * ppx

et plein de petite chose comme un texte complètement barré en entier dans une cellules (dans le xml on le retrouve pas )dans la partie CSS

[patricktoulon]

hier j'ai aussi pensé a une autre solution en ce qui concerne les attributs "index"(ROW/CELL)

je peut créer une table html base en 2 ligne avec application.rept et l'injecter dans dans ta fonctionen tant que htmldocument

et dans ta boucle sur les nœuds("ROW" ) si attribut indes alors c'est l'attribut sinon c'est la variable d'iteration de ta boucle et on applique directement les propriété

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub Macro2()
Dim plage As Range, doc As Object
    Set plage = Range("a1:f10")
    Set doc = CreateObject("htmlfile")
    doc.body.innerhtml = createHTMLtable2(plage)
'on part dans la fonction xml pour la table en lui injectant le dochtml et le xml  et  on applique les propriété en fonction de l'index( soit de la boucle soit de l'attribut)
End Sub
Function createHTMLtable2(plage)
cell = Application.Rept("<TD></TD>" & vbCrLf, plage.Columns.Count)
t = Application.Rept("<TR>" & vbCrLf & cell & "</TR>" & vbCrLf, plage.Rows.Count)
createHTMLtable2 = "<TABLE><TBODY>" & t & "</TBODY></TABLE>"
End Function

on éviterait ainsi toute tes aller retour

et a la fin ce qui n'ont pas d'id on leur met "DEFAUT"

on evite ainsi tes aller retour et mes boucle sur les interior

je sais pas si je me fait bien comprendre

[pijaku]

Oui, je t'ai bien compris.
Tu créées ta Table vide et après tu complètes.
Pourquoi pas.

En tout cas, je retrouve bien dans le css toutes les propriétés.

un texte complètement barré en entier dans une cellule

ss:StrikeThrough="1"
Bon j'avoue ne pas l'avoir traité...
Ce n'est pas le seul cas d'ailleurs : exposant (ss:VerticalAlign="Superscript") et indice (ss:VerticalAlign="Subscript")...

oui en même temps j'apprends la manip des xml ( je ne m'y était pas trop intéressé en VBA jusqu'à maintenant )

Moi non plus. J'ai découvert cette bibliothèque en même temps que ton sujet.

[patricktoulon]

voila mon idée de depart avec une table vide

j'ai un seul soucis le dimensionnement n'est pas effectués sur les cellules qui ne figurent pas dans le xml

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Option Explicit
Sub Macro2()
    Dim plage As Range, doc As Object, XXML$, roww, CCel
    Set plage = Range("h1:j6")
    XXML = plage.Value(xlRangeValueXMLSpreadsheet)
    Set doc = CreateObject("htmlfile")
    CCel = Application.Rept("<TD Id= Default></TD>" & vbCrLf, plage.Columns.Count)
    roww = "<TABLE><TBODY>" & Application.Rept("<TR>" & vbCrLf & CCel & "</TR>" & vbCrLf, plage.Rows.Count) & " </TBODY></TABLE>"
    doc.body.innerhtml = roww
    Debug.Print createhtmlbyxml(plage, doc, XXML)
    'Debug.Print XXML
End Sub
Function createhtmlbyxml(plage As Range, dochtml, XXML) As String
    plage.Cells(1, 1).Interior.Color = xlNone
    Dim docxml As New MSXML2.DOMDocument
    Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Cellules As IXMLDOMNode, Element As IXMLDOMElement, ElementTR As IXMLDOMElement, Celchilds As MSXML2.IXMLDOMNodeList
    Dim i As Long, TR, TD, z$, ppx#, cel, attTD, attTR, attID, C#, attMergeL, attmergeC
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With dochtml.getElementsByTagName("TABLE")(0): .Style.bordercollapse = "collapse": .cellspacing = 0: .Style.Width = plage.Width * ppx: End With
    With docxml
        If Not .LoadXML(Replace(XXML, "ss:Data", "Data")) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Row")
        For i = 0 To Noeuds.Length - 1
            Set ElementTR = Noeuds(i)
            attTR = ElementTR.getAttribute("ss:Index")
            Debug.Print attTR
            If IsNull(attTR) Then i = i Else i = Val(attTR)
            Set TR = dochtml.getElementsByTagName("TR")(i)
            Set SubNoeuds = Noeuds(i).ChildNodes
            C = -1
            For Each Cellules In SubNoeuds
                Set Element = Cellules: C = C + 1
                attTD = Element.getAttribute("ss:Index")
                attID = Element.getAttribute("ss:StyleID")
               If IsNull(attTD) Then C = C Else C = Val(attTD) - 1    'on change la valeur de la variable c de literation par la valeur de l'attribut index
                Set TD = TR.getElementsByTagName("TD")(C)
                 TD.iD = attID: If TD.iD = "null" Then TD.iD = "Default"
                TD.Style.Width = plage.Cells(i + 1, C + 1).Width * ppx
                TD.Style.Height = plage.Cells(i + 1, C + 1).Height * ppx
                TD.rowspan = plage.Cells(i + 1, C + 1).MergeArea.Rows.Count
                TD.colspan = plage.Cells(i + 1, C + 1).MergeArea.Columns.Count
                Set Celchilds = Cellules.ChildNodes
                If Celchilds.Length > 0 Then
                    z = Split(Celchilds(0).XML, ">")(0)
                    TD.innerhtml = Split(Split(Celchilds(0).XML, z & ">")(1), "</Data>")(0)
                End If
            Next
        Next
    End With
    createhtmlbyxml = dochtml.body.innerhtml
End Function

en tout cas plus de soucis de trou dans la table

je dirais meme presque que ca vaut pas le coup de créer la table avec le xml
apres tout ma table avant était fabriquée de la même manière sauf que de boucler sur les (row/cell )du xml je le faisait la base des row/cells de la plage
il est vrai que l'on a les id correspondant avec le xml

[patricktoulon]

je corrige ce point avec cela en fin de fonction

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
Set mesTR = dochtml.getElementsByTagName("TR")
    For ligne = 0 To mesTR.Length - 1
        For col = 0 To mesTR(ligne).Children.Length - 1
            If mesTR(ligne).Children(col).Style.Width = "" Then mesTR(ligne).Children(col).Style.Width = plage.Cells(ligne + 1, col + 1).Width * ppx
            If mesTR(ligne).Children(col).Style.Height = "" Then mesTR(ligne).Children(col).Style.Height = plage.Cells(ligne + 1, col + 1).Height * ppx
        Next
    Next

[patricktoulon]

Bonjour pijaku
dans ton dernier model tu n'a pas prévu les fusions sur ligne et antérieur a la ligne
et comme index donne le numéro de colonne exacte de la cell d'origine c'est balo

la solution la plus sur est bien la création d'une table vide avec les commentaires provisoire dans les cells de la plage dans les quel je met leur adresse
en plus du même coup je peut identifier les cellules html avec l'adresse de la cellule correspondante dans la plage
je n'est donc plus le soucis de faire correspondre un id "sxx" a l'adresse d'une cellule exemple "B3"
puisque dans la balise cell j'ai un nœud "<comment>"contenant l'adresse de la cellule
il peut en manquer tant que tu veux impossible de me perdre

affichage instantané dans ie

et maintenant je vais faire pareil pour le style css

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Option Explicit
Sub testx()
    Dim doc As Object, PLAGE, xxml, IE
    Set PLAGE = Range("A1:D10")
    Set doc = CreateObject("htmlfile")
    basetable doc, PLAGE, xxml
    'Debug.Print doc.body.innerhtml ' resultat de la base
    'Debug.Print XXML' le xml
   ' Debug.Print htmltextecell(xxml, doc)'resultat du passage de la base avec  le xml
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
IE.navigate "about:blank"
IE.document.write htmltextecell(xxml, doc)
End Sub
Function htmltextecell(xxml, doc)
    Dim docxml As New MSXML2.DOMDocument
    Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Balise As IXMLDOMNode, cellule  As IXMLDOMElement
    Dim Element As IXMLDOMElement, ElementST As IXMLDOMElement, fonts
    Dim i#, f#, A#, ppx#, z$, Ids$, innerh$, styles, Attributs, TD, Adr
     With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
     With docxml
        xxml = Replace(Replace(Replace(xxml, "ss:Data", "Data"), "<Borders>", ""), "</Borders>", "")
        If Not .LoadXML(xxml) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Comment")
        For i = 0 To Noeuds.Length - 1
            Adr = Noeuds(i).ChildNodes(0).ChildNodes(0).ChildNodes(0).XML
            Set TD = doc.getelementbyid(Adr)
            Set cellule = Noeuds(i).ParentNode: Ids = cellule.getAttribute("ss:StyleID")
            TD.iD = Ids: TD.classname = Adr
            Set Element = Noeuds(i).ParentNode.ChildNodes(0)
            If Element.tagName = "Data" Then
                innerh = Split(Noeuds(i).ParentNode.ChildNodes(0).XML, "<Data")(1)
                z = Split(innerh, ">")(0)
                innerh = Replace(Split(Replace(innerh, z & ">", ""), "</Data")(0), "xmlns:html=""http://www.w3.org/TR/REC-html40""", "")
                innerh = Replace(Replace(innerh, "xmlns:x=""urn:schemas-microsoft-com:office:excel""", ""), "html:", "")
                TD.innerhtml = innerh
            If IsDate(Range(Adr)) Then TD.innerhtml = Range(Adr).Text
 
             Set fonts = TD.getElementsByTagName("FONT")
            For f = 0 To fonts.Length - 1
                If fonts(f).Size <> "" Then fonts(f).Style.FontSize = fonts(f).Size * ppx: fonts(f).Size = "": fonts(f).removeattribute ("size")
            Next
 
 
            End If
        Next
    End With
    htmltextecell = doc.body.innerhtml
End Function
Sub basetable(doc, PLAGE, xxml)
    Dim ppx, TR, TD, Tablo, i#, col#, cel
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With doc
        .body.innerhtml = "<table><TBODY></TBODY></table>"
        With .getElementsByTagName("TABLE")(0): .Style.Width = PLAGE.Width * ppx: .Style.bordercollapse = "collapse": .cellspacing = 0: End With
        Set Tablo = .getElementsByTagName("TBODY")(0)
        For i = 1 To PLAGE.Rows.Count
            Set TR = .createelement("TR")
            Tablo.appendchild (TR)
            For col = 1 To PLAGE.Columns.Count
                Set cel = PLAGE.Cells(i, col)
                  If .getelementbyid(Replace(cel.MergeArea.Address, "$", "")) Is Nothing Then
                    cel.AddComment
                    cel.Comment.Text Text:=Replace(cel.MergeArea.Address, "$", "")
                    Set TD = .createelement("TD")
                    TD.iD = Replace(cel.MergeArea.Address, "$", ""): TD.colspan = Range(TD.iD).Columns.Count: TD.rowspan = Range(TD.iD).Rows.Count
                    TD.Style.Width = cel.MergeArea.Width * ppx: TD.Style.Height = cel.MergeArea.Height * ppx
                    TD.Style.Border = "1px solid #A9BCF5"
                    TR.appendchild (TD)
                End If
            Next
        Next
    End With
    With PLAGE
        xxml = .Value(xlRangeValueXMLSpreadsheet)
        .ClearComments
    End With
End Sub

[patricktoulon]

re
bon voila maintenant c'est presque fini la fonction de stylcss inline(style dans le code html) est faite

maintenant au craks de ce forum de m'aider a nettoyer arranger et peut être même vérifier les coquilles

principe final adopté

1 fonction basetable:
creation de la table avec 2 boucle sur (rows/cells)( quelque attributs y sont donnés comme les dimentions les id

2 fonction htmltextecell
reprise du code html base et attribution du innerhtml et changement des id correspondant a celles du XML

3 fonction html_with_CSStyle1
reprise du code html et intégration du style css dans le code html (inline) avec les données du XML


sub de test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Option Explicit
Sub testx()
    Dim doc As Object, PLAGE, xxml, IE
    Set PLAGE = Range("A1:D10")
    Set doc = CreateObject("htmlfile")
    basetable doc, PLAGE, xxml    'creation de la table de base et recuperation du xml correspondant
 
    'Debug.Print doc.body.innerhtml ' resultat de la base sans le innerhtml dans la fentre d'execution
 
    'Debug.Print XXML' si on veut examiner le xml
    doc.body.innerhtml = htmltextecell(xxml, doc) 'ajout du innerhtml et changement des id avec les données du xml
    'Debug.Print doc.body.innerhtml ' resultat avec innerhtml
 
    'Debug.Print html_with_CSStyle1(doc, PLAGE, xxml) 'afficher le code avec style dans la fentre d'execution
 
    ' apercu instantané dans internet explorer
    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True
    IE.navigate "about:blank"
    IE.document.write html_with_CSStyle1(doc, PLAGE, xxml)
End Sub

la sub basetable

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub basetable(doc, PLAGE, xxml)
    Dim ppx, TR, TD, Tablo, i#, col#, cel, r, FZ$
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    FZ = Val(ThisWorkbook.styles("Normal").font.Size * ppx) & "px"
     With doc
        .body.innerhtml = "<table><TBODY></TBODY></table>"
        With .getElementsByTagName("TABLE")(0):
            .Style.Width = (PLAGE.Width + 3) * ppx: .Style.bordercollapse = "collapse": .cellspacing = 0: .Style.FontSize = FZ
            r = .setattribute("range", Replace(PLAGE.Address, "$", ""))
        End With
        Set Tablo = .getElementsByTagName("TBODY")(0)
        For i = 1 To PLAGE.Rows.Count
            Set TR = .createelement("TR")
            r = TR.setattribute("ligne", PLAGE.Cells(i, 1).ROW)
            Tablo.appendchild (TR)
            For col = 1 To PLAGE.Columns.Count
                Set cel = PLAGE.Cells(i, col)
                If .getelementbyid(Replace(cel.MergeArea.Address, "$", "")) Is Nothing Then
                    cel.AddComment
                    cel.Comment.Text Text:=Replace(cel.MergeArea.Address, "$", "")
                    Set TD = .createelement("TD")
                    TD.iD = Replace(cel.MergeArea.Address, "$", ""): TD.colspan = Range(TD.iD).Columns.Count: TD.rowspan = Range(TD.iD).Rows.Count
                    r = TD.setattribute("address", TD.iD)
                    TD.Style.Width = cel.MergeArea.Width * ppx: TD.Style.Height = cel.MergeArea.Height * ppx
                    TD.Style.Border = "1px solid #A9BCF5"
                    TR.appendchild (TD)
                End If
            Next
        Next
    End With
    With PLAGE
        xxml = .Value(xlRangeValueXMLSpreadsheet)
        .ClearComments
    End With
End Sub

la fonction htmltextcell

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
 
Function htmltextecell(xxml, doc)
    Dim docxml As New MSXML2.DOMDocument
    Dim Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Balise As IXMLDOMNode, cellule As IXMLDOMElement
    Dim Element As IXMLDOMElement, ElementST As IXMLDOMElement, fonts
    Dim i#, f#, A#, ppx#, z$, Ids$, innerh$, styles, Attributs, TD, Adr
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    With docxml
        xxml = Replace(Replace(Replace(xxml, "ss:Data", "Data"), "<Borders>", ""), "</Borders>", "")
        If Not .LoadXML(xxml) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Comment")
        For i = 0 To Noeuds.Length - 1
            Adr = Noeuds(i).ChildNodes(0).ChildNodes(0).ChildNodes(0).XML
            Set TD = doc.getelementbyid(Adr)
            Set cellule = Noeuds(i).ParentNode: If Not IsNull(cellule.getAttribute("ss:StyleID")) Then Ids = cellule.getAttribute("ss:StyleID")
            TD.iD = Ids: TD.classname = Adr
            Set Element = Noeuds(i).ParentNode.ChildNodes(0)
            If Element.tagName = "Data" Then
                innerh = Split(Noeuds(i).ParentNode.ChildNodes(0).XML, "<Data")(1)
                z = Split(innerh, ">")(0)
                innerh = Replace(Split(Replace(innerh, z & ">", ""), "</Data")(0), "xmlns:html=""<a href="http://www.w3.org/TR/REC-html40" target="_blank">http://www.w3.org/TR/REC-html40</a>""", "")
                innerh = Replace(Replace(innerh, "xmlns:x=""urn:schemas-microsoft-com:office:excel""", ""), "html:", "")
                TD.innerhtml = innerh
 
                If IsDate(Range(Adr)) Then TD.innerhtml = Range(Adr).Text
                Set fonts = TD.getElementsByTagName("FONT")
                For f = 0 To fonts.Length - 1
                    If fonts(f).Size <> "" Then fonts(f).Style.FontSize = fonts(f).Size * ppx: fonts(f).Size = "": fonts(f).removeattribute ("size")
                Next
 
            End If
        Next
    End With
    htmltextecell = doc.body.innerhtml
End Function

et enfin la fonction html_with_CSStyle1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
 
Function html_with_CSStyle1(doc, PLAGE, xxml)
    Dim docxml As New MSXML2.DOMDocument, Noeuds As MSXML2.IXMLDOMNodeList, SubNoeuds As MSXML2.IXMLDOMNodeList
    Dim Balise As IXMLDOMNode, Element As IXMLDOMElement, ElementST As IXMLDOMElement
    Dim i#, A#, f#, ppx#, b$, FZ$, styles, Attributs, TD, fonts, StyleB$, Bweight$, BdColor$
    FZ = Val((ThisWorkbook.styles("Normal").font.Size) * ppx) & "px"
    With CreateObject("WScript.Shell"): ppx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72: End With
    'Set styledefautWk = ThisWorkbook.Styles("Normal")
    With docxml
        xxml = Replace(Replace(Replace(PLAGE.Value(xlRangeValueXMLSpreadsheet), "ss:Data", "Data"), "<Borders>", ""), "</Borders>", "")
        If Not .LoadXML(xxml) Then err.Raise .parseError.ErrorCode, , .parseError.reason
        Set Noeuds = docxml.getElementsByTagName("Style")
        For i = 0 To Noeuds.Length - 1
            'Debug.Print Noeuds(i).XML
            Set ElementST = Noeuds(i)
            'Debug.Print ElementST.getAttribute("ss:ID")
            Set TD = doc.getelementbyid(Trim(ElementST.getAttribute("ss:ID")))
            Set SubNoeuds = Noeuds(i).ChildNodes
            If Trim(ElementST.getAttribute("ss:ID")) <> "Default" Then
                If IsDate(TD.innerhtml) Or IsNumeric(TD.innerhtml) Then TD.Style.textalign = "right"
                For Each Balise In SubNoeuds
                    Set Element = Balise
                    Set Attributs = Element.Attributes
                    If Attributs.Length <> 0 Then
                        For A = 0 To Attributs.Length - 1
                            Select Case Attributs(A).BaseName
                            Case "FontName": TD.Style.fontfamily = Attributs(A).Value
                            Case "Size": TD.Style.FontSize = Round(Val(Attributs(A).Value)) * ppx
                            Case "Bold": TD.innerhtml = "<B>" & TD.innerhtml & "</B>"
                            Case "Italic": TD.innerhtml = "<i>" & TD.innerhtml & "</i>"
                            Case "StrikeThrough": TD.innerhtml = "<s>" & TD.innerhtml & "</s>"
                            Case "Underline": TD.innerhtml = "<u>" & TD.innerhtml & "</u>"
                            Case "WrapText": TD.Style.WordWrap = "break-word"
                            Case "Color"
                                If Element.tagName = "Font" And Not TD.innerhtml Like "*FONT*" Then TD.Style.Color = Attributs(A).Value
                                If Element.tagName = "Interior" Then TD.Style.backgroundcolor = Attributs(A).Value
                            Case "Horizontal": TD.Style.textalign = Attributs(A).Value
                            Case "Vertical": TD.Style.verticalAlign = Replace(Attributs(A).Value, "Center", "Middle")
                            Case "VerticalAlign":
                                If Attributs(A).Value = "Superscript" Then TD.innerhtml = "<sup>" & TD.innerhtml & "</sup>"
                                If Attributs(A).Value = "Subscript" Then TD.innerhtml = "<sub>" & TD.innerhtml & "</sub>"
                            Case "Position":
                                StyleB = Replace(Replace(Replace(Element.getAttribute("ss:LineStyle"), "Continuous", "solid "), "Dash", "dashed "), "Dot", "dotted ")
                                Bweight = Element.getAttribute("ss:Weight") & "px "
                                If StyleB = "dotted " Then Bweight = "2px "
                                If Element.getAttribute("ss:LineStyle") = "DashDot" Then StyleB = "dashed ": Bweight = "3px "
 
                                If IsNull(Element.getAttribute("ss:Color")) Then BdColor = "#000000" Else BdColor = Element.getAttribute("ss:Color")
                                Select Case Attributs(A).Value
                                Case "Top": TD.Style.bordertop = Bweight & StyleB & " " & BdColor
                                Case "Left": TD.Style.borderleft = Bweight & StyleB & " " & BdColor
                                Case "Right": TD.Style.borderright = Bweight & StyleB & " " & BdColor
                                Case "Bottom": TD.Style.borderbottom = Bweight & StyleB & " " & BdColor
                                End Select
                            End Select
                        Next
                    End If
                Next
                Set fonts = TD.getElementsByTagName("FONT")
                For f = 0 To fonts.Length - 1
                    If fonts(f).Size <> "" Then fonts(f).Style.FontSize = fonts(f).Size * ppx: fonts(f).Size = ""
                Next
                If TD.Style.FontSize = "" Then TD.Style.FontSize = FZ
                TD.innerhtml = "<FONT>" & TD.innerhtml & " </FONT>"
                If TD.Children.Length > 0 Then TD.Children(0).Style.MarginLeft = "2px": TD.Children(0).Style.MarginRight = "1px"
            End If
        Next
    End With
    Set Noeuds = Nothing
    Set Element = Nothing
    Set SubNoeuds = Nothing
    Set Balise = Nothing
    html_with_CSStyle1 = doc.body.innerhtml
End Function

resultat


un apercu du code obtenu le style est dans le html

[pijaku]

Patrick,
En ce qui concerne la fusion de cellules, j'attendais la fin de mon développement pour l'aborder.
Je préfères terminer d'abord les propriétés Weight et Line...
Mon gros souci n'est pas de ne pas y avoir pensé, c'est juste que je ne sais pas comment ça se code en HTML/CSS...

En ce qui concerne la fusion de cellules, ça apparait bien dans le fichier xml (et pour cause!!!), exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

<Cell ss:Index="2" ss:MergeAcross="4" ss:MergeDown="4" ss:StyleID="s63"/>

Signifie que pour une plage B2:H8, les cellules C2:G6 sont fusionnées... (B2 + Index 2 = C2, Across 4 = décalage de 4 cellules en colonnes ==> G, Doxn : 4 = décalage de 4 cellules en ligne ==> 6)

MergeAcross = Offset colonnes
MergeDown = Offset Lignes...

Après c'est facile, j'imagine, de le gérer... Sauf que je ne connais pas le code de "fusion de cellules" en tableau HTML......

Cette discussion m'apprend beaucoup de choses... html, css, xml, library MSXML2...
Tout cela, je l'ignorais (à part les basiques).

[patricktoulon]

re

les fusion sont bien dans le xml c'est pas ce que je voulais dire

ce que je voulais dire c'est que les cell qui ont un "index" l'index c'est le numero de la colonne
hors par exemple pour la plage de A1:d10


si A2b3 sont fusionnées je vais avoir dans le xml index 4 dans la ligne suivante alors que ce devrait etre 2
tout simplement parceque en html la ou il y a fusion de row dans les rox suivante ces cellules n'existe pas

autrement la ligne ou il y a A2:b3 il y a 3 cellule
dans la ligne en dessous il y a 2 cellules

pour le mergeacroos(xml) c'est colspan en html et rowspan en html pour le mergedown(xml)

attention ces deux propriétés ne sont pas des variable de la classe style mais html

td.style.colspan' ca n'existe pas
td.colspan ' oui

ton idée d'exploiter le xml en entier et non une par une est très bien c'est ce qui accélère en fait l'exécution du code ne vas pas mouliner afin de trouver le bon nombre de cellule après des merges crois moi tu va t'en casser la tète

car en plus de ca quand il y a des cellules vide après il y a des indexs
alors tu prends quoi comme paramètres pour déterminer le nombre
c'est ca le soucis
si dans le xml il y avait un repère pour différencier les cellules index après fusion et celle après les vides sa pourrait le faire mais c'est pas le cas

mieux vaut partir avec une table vide html sur tout que c'est facile a monter en dom comme je le fait dans tablebase

si tu a testé tu a du remarquer que comme je repéré les cellules je peut leur faire ce que je veut avec id ou pas
d'ailleurs regarde j'ai même ajouté un attribut html "range",address et les adresses sont bien placées


tu constatera aussi que je fait sauter "<border> avant l'annalise
comme ca je n'ai qu'a boucler sur les nœuds"style" . chilnodes (0)
tu constatera aussi que certain style sont remplacer par les balise equivalentes "<s><i><sub><sup> etc.......
le code html est plus propre et moins long
anaylise bien mon code tu verra

si tu veux savoir quoi que se soit en html y a qua demander

[patricktoulon]

juste une question que je pige pas

est ce que getelementbyid existe en xml chez moi ca veut pas fonctionner

msgbox d'erreur

---------------------------
Microsoft Visual Basic
---------------------------
Erreur de compilation:
Membre de méthode ou de données introuvable
---------------------------
OK Aide
---------------------------