Non j'avais tu texte;quelques bordure, fondcolor ,textecolor et je trouvais bien la feuille de style xml!
Non j'avais tu texte;quelques bordure, fondcolor ,textecolor et je trouvais bien la feuille de style xml!
De toutes façons, rien n'est encore achevé.
Mais je crois savoir pourquoi.
Je testerai et tiendrais informé.
Bon week end
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
je sais pas ce que tu en pense mais en tout cas merci pijaku
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
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
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 :
ce code suffit à faire apparaitre ceci dans le code xml :
Code : Sélectionner tout - Visualiser dans une fenêtre à part Plage.Cells(1, 1).Interior.Color = xlNone
2- Le langage html est un langage "statique".
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3<Style ss:ID="s62"> <Interior/> </Style>
Est ce que, dans l'utilisation de ce que tu souhaites faire, tu pourras modifier les cellules?
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
Je te montrerai comment, mais pas ce week end, contrer ce problème de cellules vides.
Bon week.
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 :
- CSS : LineStyle
- CSS : Weight
- 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
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
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 Submerci encore grâce a toi j'arrive un peu a comprendre le xml et ses constantes et ces nuances
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
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
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...
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)
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
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
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é
on éviterait ainsi toute tes aller retour
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
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
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.
ss:StrikeThrough="1"un texte complètement barré en entier dans une cellule
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")...
Moi non plus. J'ai découvert cette bibliothèque en même temps que ton sujet.oui en même temps j'apprends la manip des xml ( je ne m'y était pas trop intéressé en VBA jusqu'à maintenant )
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
en tout cas plus de soucis de trou dans la table
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
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
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
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
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
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 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
resultat
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
un apercu du code obtenu le style est dans le html
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:
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)
Code : Sélectionner tout - Visualiser dans une fenêtre à part <Cell ss:Index="2" ss:MergeAcross="4" ss:MergeDown="4" ss:StyleID="s63"/>
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......MergeAcross = Offset colonnes
MergeDown = Offset Lignes...
Cette discussion m'apprend beaucoup de choses... html, css, xml, library MSXML2...
Tout cela, je l'ignorais (à part les basiques).
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
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
---------------------------
Vous avez un bloqueur de publicités installé.
Le Club Developpez.com n'affiche que des publicités IT, discrètes et non intrusives.
Afin que nous puissions continuer à vous fournir gratuitement du contenu de qualité, merci de nous soutenir en désactivant votre bloqueur de publicités sur Developpez.com.
Partager