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
|
Public mDom As DOMDocument40
Public Function AjouterPatient(patient As PatientType) As Boolean
Dim xmlPatientelle As IXMLDOMElement
Dim xmlPatient As IXMLDOMElement
Dim xmlDateNaissance As IXMLDOMElement
Dim xmlTelephone As IXMLDOMElement
Dim xmlTelephone1 As IXMLDOMElement
Dim xmlTelephone2 As IXMLDOMElement
Dim xmlTelephone3 As IXMLDOMElement
Dim xmlAssure As IXMLDOMElement
Dim xmlOrganisme As IXMLDOMElement
Dim xmlAdresse As IXMLDOMElement
''
Set mDom = New MSXML2.DOMDocument40
mDom.appendChild mDom.createProcessingInstruction("xml", "version='1.0' encoding='UTF-8'")
Set xmlPatientelle = AjouterElement("Patientelle", mDom)
'''
AjouterPatient = False
'Set xmlPatientelle = mDom.selectSingleNode("Patientelle") ' positionnement sur la racine
Set xmlPatient = AjouterElement("Patient", xmlPatientelle)
AjouterElement("ID", xmlPatient).Text = patient.ID
AjouterElement("Nom", xmlPatient).Text = patient.Nom
AjouterElement("Prenom", xmlPatient).Text = patient.Prénom
AjouterElement("Sexe", xmlPatient).Text = patient.Sexe
AjouterElement("NumSS", xmlPatient).Text = patient.NumSS
Set xmlDateNaissance = AjouterElement("DateNaissance", xmlPatient)
AjouterElement("Jour", xmlDateNaissance).Text = patient.DateNaissance.Jour
AjouterElement("Mois", xmlDateNaissance).Text = patient.DateNaissance.Mois
AjouterElement("Annee", xmlDateNaissance).Text = patient.DateNaissance.Année
Set xmlTelephone = AjouterElement("Telephone", xmlPatient)
Set xmlTelephone1 = AjouterElement("TelephoneA", xmlTelephone)
AjouterElement("Numero", xmlTelephone1).Text = patient.Telephone(1).Numero
AjouterElement("Qui", xmlTelephone1).Text = patient.Telephone(1).Qui
Set xmlTelephone2 = AjouterElement("TelephoneB", xmlTelephone)
AjouterElement("Numero", xmlTelephone2).Text = patient.Telephone(2).Numero
AjouterElement("Qui", xmlTelephone2).Text = patient.Telephone(2).Qui
Set xmlTelephone3 = AjouterElement("TelephoneC", xmlTelephone)
AjouterElement("Numero", xmlTelephone3).Text = patient.Telephone(3).Numero
AjouterElement("Qui", xmlTelephone3).Text = patient.Telephone(3).Qui
Set xmlAssure = AjouterElement("Assure", xmlPatient)
AjouterElement("Nom", xmlAssure).Text = patient.Assuré.Nom
AjouterElement("Prenom", xmlAssure).Text = patient.Assuré.Prénom
AjouterElement("NumSS", xmlAssure).Text = patient.Assuré.NumSS
Set xmlOrganisme = AjouterElement("Organisme", xmlAssure)
AjouterElement("Nom", xmlOrganisme).Text = patient.Assuré.Organisme.Nom
AjouterElement("Code", xmlOrganisme).Text = patient.Assuré.Organisme.Code
Set xmlAdresse = AjouterElement("Adresse", xmlAssure)
AjouterElement("Rue", xmlAdresse).Text = patient.Assuré.Adresse.Rue
AjouterElement("CP", xmlAdresse).Text = patient.Assuré.Adresse.CP
AjouterElement("Ville", xmlAdresse).Text = patient.Assuré.Adresse.Ville
End Function
Public Function ChargerXML()
Set mDom = New MSXML2.DOMDocument40
' Chargement du document XML
mDom.async = False ' permet de charger entièrement le document en mémoire avant le traitement
If mDom.Load(App.Path & "\Sauve\patient.xml") = False Then
MsgBox "Erreur de lecture du document XML"
End
End If
End Function
Public Function SauverXML()
IndentXML mDom.Xml 'l'erreur se situe ici (mDom.xml est incomplet quand je l'espionne)
mDom.save App.Path & "\Sauve\patient.xml"
End Function
Public Function AjouterElement(ByVal Name As String, ByRef ElementParent As IXMLDOMNode, Optional ByRef InsertBefore As IXMLDOMNode = Nothing) As IXMLDOMElement
'Ajouter un élément dans le document DOM
Set AjouterElement = mDom.createNode(NODE_ELEMENT, Name, "")
ElementParent.InsertBefore AjouterElement, InsertBefore
End Function
Public Function IndentXML(ByVal Xml As String) As String
'Indente le XML qui sinon est sur une seule ligne
Dim NbIndent As Integer
Dim Pos As Long
NbIndent = 0
Pos = InStr(Xml, "><")
Do While Pos <> 0
If Mid(Xml, Pos - 1, 1) = "/" Then
If Mid(Xml, Pos + 2, 1) = "/" Then
'/></
NbIndent = NbIndent - 1
Else
'/><
NbIndent = NbIndent
End If
Else
If Mid(Xml, Pos + 2, 1) = "/" Then
'></
NbIndent = NbIndent - 1
Else
'><
'Regarde si le node est une basile de fin ex: "</NodeInfo>"
Pos = InStrRev(Xml, "<", Pos)
Select Case Mid(Xml, Pos + 1, 1)
Case "/", "!"
'</NodeInfo><Created>
'ou
'<!-- C'est un commentaire
NbIndent = NbIndent
Case Else
'<AuditPool><Created>
NbIndent = NbIndent + 1
End Select
End If
End If
Xml = Replace(Xml, "><", ">" & vbCrLf & String(NbIndent, vbTab) & "<", , 1)
Pos = InStr(Xml, "><")
Loop
IndentXML = Xml
End Function |
