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
|
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 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 SauverXML()
'Indente le XML qui sinon est sur une seule ligne
Dim NbIndent As Integer
Dim Pos As Long
Dim Xml As String
Xml = mDom.Xml
NbIndent = 0
Pos = InStr(Xml, "><")
Do While Pos <> 0
Change = True
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
'></
'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 - 1
Case Else
'<AuditPool></AuditPool>
NbIndent = NbIndent
End Select
'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, "><")
DoEvents
Loop
Open App.Path & "\Sauve\patient.xml" For Output As #1
Print #1, Xml
Close #1
End Function |
Partager