accesstoolbox/source/modules/FichierXML.bas

Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit
'******
' Créer et éditer un ficher XML complexe
' v 1
'******
Private cheminXML As String  'nom du fichier à créer
Private oXML As MSXML2.DOMDocument60        'ref au fichier xml
Private oNode As MSXML2.IXMLDOMNode       'noeud principal du document
Private n(99) As MSXML2.IXMLDOMNode       'arborescence des noeuds
Private position As Integer          'position dans l'arborescence
Private S As Boolean                      'activer la sauvegarde progressive? (deboguage)

Private Sub exempleCreationXML()
'exemple d'utilisation de cette classe
  Dim xml As New FichierXML

  xml.creer ("c:\essai.xml")
  
  xml.ouvrirNoeud "a"
  xml.ajout "a1", "essai"
  
  xml.ouvrirNoeud "b"
  xml.ajout "b1", 123
  xml.ajout "b2", #1/1/2015#
  xml.fermerNoeud "b"
  
  xml.ajout "a2", "essai2"
  
  xml.enregistrer

End Sub

Public Sub creer(chemin As String, Optional nomNoeudPrincipal As String = "", Optional svgConstante As Boolean = False)

  If initialiser(nomNoeudPrincipal, svgConstante) = False Then GoTo fin
  If majCheminXML(chemin) = False Then GoTo fin
  If S = True Then Call enregistrer
  
fin:
End Sub

Public Sub enregistrer(Optional chemin As String = "", Optional ecraser As Boolean = True)
On err GoTo err

   If Len(chemin) > 0 Then
     If majCheminXML(chemin) = False Then GoTo fin
   End If
   oXML.Save cheminXML
   
fin:
  Exit Sub
err:
  MsgBox "Erreur (sauvegarde du fichier XML): " & err.Description
  GoTo fin
End Sub

Private Sub class_Initialize()
  'Call initialiser
End Sub

Private Function initialiser(ByVal nomNoeudPrincipal As String, ByVal svgConstante As Boolean) As Boolean
initialiser = False

   S = svgConstante
   Set oXML = New MSXML2.DOMDocument60
   Set oNode = oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
   oXML.appendChild oNode
   Set n(0) = oXML
   position = 0
   If Len(nomNoeudPrincipal) = 0 Then nomNoeudPrincipal = "Fichier"
   Call ouvrirNoeud(nomNoeudPrincipal)
   
initialiser = True
End Function

Private Sub class_Terminate()
On Error GoTo fin
Dim noeud As Variant
  For Each noeud In n
    Set noeud = Nothing
  Next noeud
  Set oNode = Nothing
  Set oXML = Nothing
fin:
End Sub

Private Function majCheminXML(chemin As String) As Boolean
On Error GoTo err
majCheminXML = False

  If Dir(repFichier(chemin), vbDirectory) = "" Then GoTo errRepCible
  If Right(chemin, 4) <> ".xml" Then chemin = chemin & ".xml"
  cheminXML = chemin
  
majCheminXML = True
fin:
  Exit Function
err:
  MsgBox "Erreur: " & err.Description
  GoTo fin
errRepCible:
  MsgBox "Erreur: le répertoire cible n'existe pas, veuillez le créer ou prévenir un administrateur"
  GoTo fin
End Function

Public Sub ouvrirNoeud(nom As String)
'ouvre un nouveau noeud
  Set n(position + 1) = n(position).appendChild(oXML.createElement(nom))
  position = position + 1
End Sub

Public Sub fermerNoeud(Optional nom As String)
'ferme le noeud (nom à titre indicatif)
If position > 0 Then position = position - 1
fin:
End Sub

Public Sub ajout(ByVal nom As String, ByVal valeur As Variant, Optional attribut As String = "", Optional valAttribut As Variant = "")
'ajoute un noeud texte (avec son attribut si nécessaire)
Dim elt As MSXML2.IXMLDOMElement      'noeud 'element'
Dim oAttribut As IXMLDOMAttribute

   Set elt = n(position).appendChild(oXML.createElement(nom))
   elt.Text = CStr(Nz(valeur, ""))

   If Len(attribut) > 0 Then
     Set oAttribut = oXML.createAttribute(CStr(Nz(attribut, "")))
     oAttribut.Text = valAttribut
     elt.setAttributeNode oAttribut
   End If
   
End Sub