XML-Verwaltung leicht gemacht (inkl. XPath) XML ist ein mächtiges System, mit diesem kleinen Modul wird die Grundverwaltung zum Kinderspiel
Autor:   Florian Platzer	Bewertung:     [ Jetzt bewerten ]	Views:  27.248
www.vbmaster.gbadmin.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 28 Bewertung insgesamt: nützlich Durchschnittliche Bewertung: 3.3 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Viele Entwickler lassen sich von der Komplexität des "XML-Systems" abschrecken und verzichten deshalb darauf. Leider lassen sie sich dadurch einiges entgehen, denn wer sich wirklich mit XML auseinandersetzt, erkennt die klaren Vorteile gegenüber einer Ini-Datei, der Registry bzw. einer extra angelegten Mini-DB.

Zwar gibt es auf vb@rchiv schon einige XML-Tipps, dieses Modul, welches ich Ihnen hier vorstellen, kapselt die wichtigsten Funktionen und ist somit individuell einsatzbereit (verwendete XML-Version: 2).

Besonderes Feature: Unterstützung von XPath

Erstellen Sie ein neues Projkekt (Standard-EXE), aktivieren den Verweis "Microsoft XML, v2..." und fügen Sie dem Projekt ein Modul hinzu mit folgendem Code hinzu.

Option Explicit
 
' ##############################
' #### FileExists-Function #####
 
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH = 260
 
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
Private Type WIN32_FIND_DATA
  dwFileAttributes As Long
  ftCreationTime As FILETIME
  ftLastAccessTime As FILETIME
  ftLastWriteTime As FILETIME
  nFileSizeHigh As Long
  nFileSizeLow As Long
  dwReserved0 As Long
  dwReserved1 As Long
  cFileName As String * MAX_PATH
  cAlternate As String * 14
End Type
 
Private Declare Function FindFirstFile Lib "Kernel32" _
  Alias "FindFirstFileA" ( _
  ByVal lpFileName As String, _
  lpFindFileData As WIN32_FIND_DATA) As Long
 
Private Declare Function FindClose Lib "Kernel32" ( _
  ByVal hFindFile As Long) As Long
 
' #### FileExists-Function #####
' ##############################
 
' Konstante für den Kopf der Datei (natürlich beliebig ersetzbar)
Private Const sXMLHeader As String = "Header" 
 
' Typ beim Füllen eines XML-Objekts
Public Enum XMLType 
  xFile = 0
  xString = 1
End Enum
 
' Variable für den aktuell verwendeten Pfad
Private sXMLPath As String 
 
Private oXML As MSXML2.DOMDocument
Private oElement As IXMLDOMElement

' ##############################
' #### FileExists-Function #####
 
Public Function FileExists(ByVal sFile As String) As Boolean
  Dim WFD As WIN32_FIND_DATA
  Dim hFile As Long
 
  hFile = FindFirstFile(sFile, WFD)
  FileExists = hFile <> INVALID_HANDLE_VALUE
  Call FindClose(hFile)
End Function

Public Sub XML_Init()
  ' XML-Objekt wird instanziert
  Set oXML = New MSXML2.DOMDocument 
End Sub

Public Sub XML_DeInit()
  ' XML-Objekt wird gelöscht
  Set oXML = Nothing 
End Sub

' Erstellen einer neuen XML-Datei und Speichern unter dem übergebenen Dateinamen
' Bereits existierende Datei wird überschrieben
Public Function Create(ByVal sFileName As String) As Boolean
  Create = False
 
  If sFileName <> "" Then
    If FileExists(sFileName) Then Kill sFileName
 
    If FileExists(sFileName) Then
      Err.Raise 70
    Else
      Set oXML = New MSXML2.DOMDocument
      oXML.async = False
 
      Call oXML.Save(sFileName)
 
      sXMLPath = sFileName
      Create = True
    End If
  Else
    Err.Raise 52
  End If
End Function

' Speichern der Daten
Public Sub WriteData(ByVal sQuery As String, ByVal sValue As String)
  Dim sElements() As String
  Dim sXPath As String
  Dim n As Integer
  Dim sData As String
 
  sQuery = sXMLHeader & "/" & sQuery
  sElements = Split(sQuery, "/")
  sXPath = ""
 
  On Error Resume Next
 
  For n = LBound(sElements) To UBound(sElements)
    sXPath = sXPath & sElements(n)
    Err.Clear
    sData = oXML.getElementsByTagName(sXPath).Item(0).Text
 
    If Err.Number <> 0 Then
      Set oElement = oXML.createElement(sElements(n))
      Err.Clear
      If oXML.getElementsByTagName(sXPath).length = 0 Then
        If n = LBound(sElements) Then
          oXML.appendChild oElement
        Else
          oXML.getElementsByTagName(Left(sXPath, Len(sXPath) - Len(sElements(n)) - 1)).Item(0).appendChild oElement
        End If
      Else
        oXML.getElementsByTagName(sXPath).Item(0).appendChild oElement
      End If
 
      If n = UBound(sElements) Then oElement.Text = sValue
      If Err.Number <> 0 Then Err.Raise Err.Number
    End If
    sXPath = sXPath & "/"
  Next n
 
  On Error GoTo 0
End Sub

' Lesen der Daten (Default-Wert wird verwendet, 
' sollte das Laden eines gespeicherten Wertes fehlschlagen
' (z.B. wenn er nicht existiert)
Public Function ReadData(ByVal sQuery As String, Optional ByVal sDefault As String = "") As String
  On Error Resume Next
  Err.Clear
  ReadData = oXML.getElementsByTagName(sQuery).Item(0).Text
  If Err.Number <> 0 Then ReadData = sDefault
  On Error GoTo 0
End Function

' Löschen eines Knotens
Public Function DeleteData(ByVal sQuery As String) As Boolean
  On Error Resume Next
  Dim oDeleteNode As MSXML2.IXMLDOMNode
  Set oDeleteNode = oXML.selectSingleNode(sXMLHeader & "/" & sQuery)
  Call oDeleteNode.parentNode.removeChild(oDeleteNode)
  DeleteData = (Err.Number = 0)
  On Error GoTo 0
End Function

' Füllen eines XML-Objekts
Public Function Load(ByVal sSource As String, Optional oType As XMLType = xFile) As Boolean
  Set oXML = New MSXML2.DOMDocument
  oXML.async = False
  Select Case oType
    Case xFile
      Load = oXML.Load(sSource)
      sXMLPath = sSource
    Case xString
      Load = oXML.loadXML(sSource)
  End Select
 
  If oXML.parseError.errorCode <> 0 Then
    MsgBox "Fehler beim Laden:" & vbCrLf & vbCrLf & "#: " & _
      oXML.parseError.errorCode & vbCrLf & "Zeile: " & _
      oXML.parseError.Line & vbCrLf & "Position: " & _
      oXML.parseError.linepos & vbCrLf & "Beschreibung: " & _
      oXML.parseError.reason & vbCrLf, vbExclamation, "XML Parse Error"
    Load = False
  End If
End Function

' Speichern: Sollte über Load(oType:=xFile) 
' oder Create eine Datei erstelt worden sein, muss kein Dateiname 
' übergeben werden, ansonsten schon
Public Function Save(Optional ByVal sFileName As String = "") As Boolean
  Save = False
  If sFileName = "" Then sFileName = sXMLPath
 
  If sFileName = "" Then
    Err.Raise 52
    Exit Function
  End If
 
  If FileExists(sFileName) Then Kill sFileName
 
  If FileExists(sFileName) Then
    Err.Raise 70
    Exit Function
  End If
 
  oXML.Save sFileName
  Save = True
End Function

' Gibt den aktuellen Dateinamen zurück 
' (z.B. als Sicherheitsüberprüfung vor dem Speichern sinnvoll)
Public Function FileName(Optional ByVal bFullPath As Boolean = False, _
  Optional ByVal bFileType As Boolean = True) As String
 
  FileName = IIf(bFullPath, sXMLPath, _
    Right(sXMLPath, Len(sXMLPath) - InStrRev(sXMLPath, "\")))
  If Not bFileType Then FileName = Left(FileName, InStrRev(FileName, ".") - 1)
End Function

Nun zum Beispielprojekt:
Fügen Sie der Form 3 CommandButtons hinzu:

• cmdCreate ("Erstellen")
• cmdTest ("Testwerte speichern")
• cmdDelete ("Main-Werte löschen")

Option Explicit
 
Private Sub cmdCreate_Click()
  XML_Init
  Call Create(App.Path & "\data.xml")
  cmdTest.Enabled = True
  cmdDelete.Enabled = True
End Sub
 
Private Sub cmdDelete_Click()
  Call DeleteData("main_info")
  Call DeleteData("main_version")
  Call Save
End Sub
 
Private Sub cmdTest_Click()
  Call WriteData("main_info", "test-xml")
  Call WriteData("main_version", "1.0")
  Call WriteData("data/data_folder_1", "data1_1")
  Call WriteData("data/data_folder_1", "data1_2")
  Call WriteData("data/data_folder_1", "data1_3")
  Call WriteData("data/data_folder_1", "data1_4")
  Call WriteData("data/data_folder_1", "data1_5")
  Call WriteData("data/data_folder_2", "data2_1")
  Call WriteData("data/data_folder_2", "data2_2")
  Call WriteData("data/data_folder_2", "data2_3")
  Call WriteData("data/data_folder_2", "data2_4")
  Call WriteData("data/data_folder_2", "data2_5")
  Call WriteData("user/name", "Florian")
  Call WriteData("user/adress", "xyz")
  Call WriteData("user/mail", "a@b.c")
  Call WriteData("extra/long/path/to/show/xpath/function/in/module", "great ;)")
  Call Save
End Sub

Viel Spaß beim Testen