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
| Option Explicit
Sub Activation()
Dim TypeDemande
TypeDemande = "Démarrage"
Initialize ("Démarrage")
End Sub
Sub Initialize(TypeDemande)
Dim CompletePath, Destination, Filename, i, Feuille, Limite, Client
Dim Prefixe, Result, NbDemandes
Dim fs, f, ts, XML, XMLFileObject, XMLFile
Set fs = CreateObject("Scripting.FileSystemObject")
Prefixe = "CLIENT"
Filename = Prefixe & "TOTO.xml"
CompletePath = Destination & "\" & Filename
i = 4
Set Feuille = ThisWorkbook.Sheets(2)
While Feuille.Cells(i, 1) <> "" And Feuille.Cells(i, 2) <> ""
i = i + 1
Wend
If Feuille.Cells(i, 1) = "" And (Feuille.Cells(i, 2) <> "" Or Feuille.Cells(i, 2) <> "") _
And NbDemandes < Limite + 1 Then
XML = ThisWorkbook.StructureXML(Destination, Filename, Client)
While Feuille.Cells(i, 1) = "" And (Feuille.Cells(i, 2) <> "" Or Feuille.Cells(i, 2) <> "") _
And NbDemandes < Limite + 1
TEL = Feuille.Cells(i, 2)
Result = ThisWorkbook.DemandeXML(CompletePath, TypeDemande, TEL)
' Feuille.Cells(i, 1).Value = "Créée"
NbDemandes = NbDemandes + 1
i = i + 1
Wend
' Méthode d'indentation n°1
XMLFile = ThisWorkbook.BeautifyXML(CompletePath)
Set XMLFileObject = fs.OpenTextFile(CompletePath, 2)
XMLFileObject.Write XMLFile
XMLFileObject.Close
' Méthode d'indentation n°2
' ThisWorkbook.IndentXML CompletePath, True, True
Else
MsgBox "Aucune donnée disponible pour la création de fichier XML."
End
End If
End Sub
Public Function StructureXML(Destination, Filename, Client) As Variant
Dim fs, f, XML, XNodeBranche, XFeuille, XNode
Set fs = CreateObject("Scripting.FileSystemObject")
If Not fs.FolderExists(Destination) Then
StructureXML = "Répertoire inexistant"
End
Else
Dim objDOM As DOMDocument
Dim XNodeRoot, Demandes_node As IXMLDOMElement
Dim oPi As IXMLDOMProcessingInstruction
Set objDOM = New DOMDocument
objDOM.resolveExternals = True
Set oPi = objDOM.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
Set oPi = objDOM.insertBefore(oPi, objDOM.childNodes.Item(0))
Set oPi = objDOM.createProcessingInstruction("xml-stylesheet", "type=""text/xsl"" href=""CLIENT_TOTO.xslt""")
Set oPi = objDOM.insertBefore(oPi, objDOM.childNodes.Item(1))
'Root
Set XNodeRoot = objDOM.createElement("FLUX")
XNodeRoot.setAttribute "xmlns", "http://www.toto.com/appli"
XNodeRoot.setAttribute "xmlns:xsi", "http://www.w3.org/2001/XMLSchema-instance"
XNodeRoot.setAttribute "xsi:schemaLocation", "http://www.toto.com/appli CLIENT_TOTO.xsd"
objDOM.appendChild XNodeRoot
Set XNodeBranche = objDOM.createNode(1, "CLIENT", "")
Set XFeuille = objDOM.createTextNode("TOTO")
XNodeBranche.appendChild XFeuille
XNodeRoot.appendChild XNodeBranche
Set Demandes_node = XNodeBranche.ownerDocument.createElement("DEMANDES")
XNodeRoot.appendChild Demandes_node
objDOM.Save Destination & "\" & Filename
Set XNodeRoot = Nothing
Set XNode = Nothing
Set objDOM = Nothing
StructureXML = True
End If
End Function
Public Function DemandeXML(CompletePath, TypeDemande, TEL)
Dim CodeMotif, LoadResult
Dim objDOM As DOMDocument
Dim XNodeRoot, Demande_node, Demandes_node As IXMLDOMElement
Dim Children As IXMLDOMNodeList
Set objDOM = New DOMDocument
objDOM.async = False
LoadResult = objDOM.Load(CompletePath)
Set Demandes_node = objDOM.selectSingleNode("/FLUX/DEMANDES")
Select Case TypeDemande
Case "DEMARRAGE"
Test = False
End Select
Set Demande_node = Demandes_node.ownerDocument.createElement("DEMANDE")
Demande_node.setAttribute "xsi:type", "DEMARRAGE"
Demandes_node.appendChild Demande_node
objDOM.Save CompletePath
DemandeXML = True
End Function
Function BeautifyXML(XMLFile)
Dim xmlDoc As New DOMDocument40
'Create the reader.
Dim rdr As New SAXXMLReader40
'Create the writer.
Dim wrt As New MXXMLWriter40
'Load the DOM document.
xmlDoc.async = False
xmlDoc.resolveExternals = False
xmlDoc.Load (XMLFile)
'Set properties on the XML writer.
wrt.byteOrderMark = True
wrt.omitXMLDeclaration = False
wrt.indent = True
'Set the XML writer to the SAX content handler.
Set rdr.contentHandler = wrt
Set rdr.dtdHandler = wrt
Set rdr.errorHandler = wrt
rdr.putProperty "http://xml.org/sax/properties/lexical-handler", wrt
rdr.putProperty "http://xml.org/sax/properties/declaration-handler", wrt
'Parse the DOMDocument object.
rdr.Parse xmlDoc
BeautifyXML = wrt.output
End Function
Public Sub IndentXML(CompletePath, Optional bUnindent As Boolean, Optional bLeaveHeader As Boolean)
Dim oXMLDoc As DOMDocument
Dim oXSLT As DOMDocument
Dim XSL_FILE As String
Dim sResult As String
Dim sIndent As String
Dim LoadResult
Const QT = """"
Set oXMLDoc = New DOMDocument
oXMLDoc.async = False
LoadResult = oXMLDoc.Load(CompletePath)
Set oXSLT = New DOMDocument
If bUnindent Then
sIndent = "no"
Else
sIndent = "yes"
End If
XSL_FILE = _
"<?xml version=" & QT & "1.0" & QT & " encoding=" & QT & "UTF-8" & QT & "?>" & vbCrLf & _
"<xsl:stylesheet version=" & QT & "1.0" & QT & " xmlns:xsl=" & QT & "http://www.w3.org/1999/XSL/Transform" & QT & ">" & vbCrLf & _
" <xsl:output method=" & QT & "xml" & QT & " version=" & QT & "1.0" & QT & " encoding=" & QT & "UTF-8" & QT & " indent=" & QT & sIndent & QT & "/>" & vbCrLf & _
" <xsl:template match=" & QT & "@* | node()" & QT & ">" & vbCrLf & _
" <xsl:copy>" & vbCrLf & _
" <xsl:apply-templates select=" & QT & "@* | node()" & QT & " />" & vbCrLf & _
" </xsl:copy>" & vbCrLf & _
" </xsl:template>" & vbCrLf & _
"</xsl:stylesheet>"
oXMLDoc.async = False
oXSLT.async = False
oXSLT.loadXML XSL_FILE
If oXSLT.parseError.errorCode = 0 Then
If oXSLT.readyState = 4 Then
sResult = oXMLDoc.transformNode(oXSLT.documentElement)
' Get rid of the added header line
If Not bLeaveHeader Then
sResult = Replace$(sResult, "<?xml version=" & QT & "1.0" & QT & " encoding=" & QT & "UTF-16" & QT & "?>", vbNullString, , , vbTextCompare)
End If
oXMLDoc.loadXML sResult
oXMLDoc.Save CompletePath
End If
Else
Err.Description = oXSLT.parseError.reason & vbCrLf & _
"Line: " & oXSLT.parseError.Line & vbCrLf & _
"XML: " & oXSLT.parseError.srcText
Err.Raise 1006
End If
Set oXSLT = Nothing
End Sub |
