Writing XML file with VBA

Question

I need to write a quite large, readable xml file with vba for my work, for which I store the data from several other files in an array. I can't manage to get the individual elements in the right order and the elements from the 2nd loop only appear under the 1st child element, instead of in all of them.

With my code I get the following output so far.

<?xml version="1.0" encoding="UTF-8"?>
<Root name="">
    <config type="Typ1">
        <item name="It's a Test 1">
        </item><item name="It's a Test 2">
        </item><item name="It's a Test 3">
        </item><item name="It's a Test 4">
        </item>
    </config><config type="Typ2">
        
    </config><config type="Typ3">   

    </config>
</Root>

However, the file should actually look like this.

<?xml version="1.0" encoding="UTF-8"?>
<Root name="">
    <config type="Typ1">
        <item name="It's a Test 1" />
        <item name="It's a Test 2" />
        <item name="It's a Test 3" />
        <item name="It's a Test 4" />
    <config type="Typ2">
        <item name="It's a Test 1" />
        <item name="It's a Test 2" />
        <item name="It's a Test 3" />
        <item name="It's a Test 4" />       
    <config type="Typ3">    
        <item name="It's a Test 1" />
        <item name="It's a Test 2" />
        <item name="It's a Test 3" />
        <item name="It's a Test 4" />
    </config>
</Root>

This is the dummy code that goes with it.

Option Base 1

Public Sub Write_XML()
 
Dim h, i, j As Integer
Dim XML, Root, Child(), Grandchild(), RootAttribut, Attribut() As Object
Dim w(), x(), y() As String
 
 
ReDim w(3)
ReDim x(4)
ReDim y(4)
ReDim Attribut(4)
ReDim Child(4)
ReDim Grandchild(4)
 
w(1) = "Typ1"
w(2) = "Typ2"
w(3) = "Typ3"
 
For h = 1 To 4
    x(h) = "It's a Test " + CStr(h)
Next h
 
 
Set XML = CreateObject("MSXML2.DOMDocument")
 
XML.LoadXML ""
XML.appendChild XML.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
 
i = 1
j = 1
 
Set Root = XML.createElement("Root")
Set RootAttribut = XML.createAttribute("name")
RootAttribut.Text = Name
Root.setAttributeNode RootAttribut
Root.appendChild XML.createTextNode(vbNewLine + vbTab)

Do Until i > 3
    Set Child(i) = XML.createElement("config")
 
    Set Attribut(i) = XML.createAttribute("type")
    Attribut(i).NodeValue = w(i)
    Child(i).setAttributeNode Attribut(i)
 
    Child(i).appendChild XML.createTextNode(vbNewLine + vbTab + vbTab)
 
    Do Until j > 4
        Set Grandchild(j) = XML.createElement("item")
 
        Set Attribut(j) = XML.createAttribute("name")
        Attribut(j).NodeValue = x(j)
        Grandchild(j).setAttributeNode Attribut(j)
 
        Grandchild(j).appendChild XML.createTextNode(vbNewLine + vbTab + vbTab)
       
        Child(i).appendChild Grandchild(j)
      
        j = j + 1
    Loop
    Child(i).appendChild XML.createTextNode(vbNewLine + vbTab)
    Root.appendChild Child(i)
 
    i = i + 1
Loop
 
Root.appendChild XML.createTextNode(vbNewLine)

XML.appendChild (Root)

XML.Save "TestXML.xml"
 
End Sub

I am quite a beginner with both vba and xml, I hope someone here can help me.

Answer 1

Here's an example. It's a bit lengthy, but note that most of the code is just reusable utility methods (one of which will break with your Option Base 1...)

Sub Tester()

    Dim XML As Object, rt As Object, nd As Object, i As Long, n As Long
    
    Set XML = EmptyDocument()
    
    Set rt = CreateWithAttributes(XML, "Root", "", Array("name", ""))
    XML.appendchild rt
    
    For i = 1 To 3
        Set nd = CreateWithAttributes(XML, "config", "", Array("type", "Typ" & i))
        rt.appendchild nd
        For n = 1 To 4
            nd.appendchild _
                 CreateWithAttributes(XML, "item", "", _
                                      Array("name", "It's a Test " & n))
        Next n
    Next i
    
    Debug.Print PrettyPrintXML(XML.XML)
End Sub


' ### everything below here is a utility method ###

'Utility method: create and return an element, with
'   optional value and attributes
Function CreateWithAttributes(doc As Object, elName As String, _
                elValue As String, Optional attr As Variant = Empty) As Object
    Dim el, u, i As Long, att As Object, txt As Object
    'create the node
    Set el = doc.CreateNode(1, elName, "")
    'if have attributes, loop and add
    'passed in as Array(attr1Name, attr1Value, attr2Name, attr1Value,...)
    If Not IsEmpty(attr) Then
        For i = 0 To UBound(attr) Step 2
            Set att = doc.CreateAttribute(attr(i))
            att.Value = attr(i + 1)
            el.Attributes.setNamedItem att
        Next i
    End If
    'any element content to add?
    If Len(elValue) > 0 Then
        Set txt = doc.createTextNode(elValue)
        el.appendchild txt
    End If
    Set CreateWithAttributes = el
End Function

'create and return an empty xml doc
Function EmptyDocument() As Object
    Dim XML
    Set XML = CreateObject("MSXML2.DOMDocument")
    XML.LoadXML ""
    XML.appendchild XML.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8""")
    Set EmptyDocument = XML
End Function

'https://stackoverflow.com/questions/1118576/how-can-i-pretty-print-xml-source-using-vb6-and-msxml
Public Function PrettyPrintXML(XML As String) As String

  Dim Reader As Object 'New SAXXMLReader60
  Dim Writer As Object 'New MXXMLWriter60
  
  Set Reader = CreateObject("MSXML2.SAXXMLReader.6.0")
  Set Writer = CreateObject("MSXML2.MXXMLWriter.6.0")
  
  Writer.indent = True
  Writer.standalone = False
  Writer.omitXMLDeclaration = False
  Writer.Encoding = "utf-8"

  Set Reader.contentHandler = Writer
  Set Reader.dtdHandler = Writer
  Set Reader.errorHandler = Writer

  Call Reader.putProperty("http://xml.org/sax/properties/declaration-handler", _
          Writer)
  Call Reader.putProperty("http://xml.org/sax/properties/lexical-handler", _
          Writer)

  Call Reader.Parse(XML)

  PrettyPrintXML = Writer.output

End Function

Answer 2

We're all here to have some fun, right?! Well, OK then!

Open your Excel workbook and hit Alt+F11 to open the Visual Basic Editor. Select Insert/Class Module from the main menu. Copy the following code into the new class module and then rename it XDocument.

' Class XDocument definition
Option Explicit

Private Type InstanceData
    Root As New XElement
End Type

Private MyData As InstanceData

' Tag property getter
Public Property Get Root() As XElement
    
    Set Root = MyData.Root

End Property

' Get string representation
Public Function ToString() As String
    
    ToString = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & MyData.Root.ToString(0)

End Function

Select Insert/Class Module from the main menu. Copy the following code into the new class module and then rename it XElement.

' Class XElement definition
Option Explicit

Private Type InstanceData
    Tag As String
    Attributes As New Collection
    Children As New Collection
End Type

Private MyData As InstanceData

' Tag property getter
Public Property Get Tag() As String
    
    Tag = MyData.Tag

End Property

' Tag property setter
Public Property Let Tag(ByVal Value As String)
    
    MyData.Tag = Value

End Property

' Add attribute
Public Sub AddAttribute(ByVal Name As String, ByVal Value As String)
    
    Dim attr As New XAttribute
    
    attr.Name = Name
    attr.Value = Value
    MyData.Attributes.Add attr

End Sub

' Add child element
Public Sub AddChild(ByVal child As XElement)
    
    MyData.Children.Add child

End Sub

' Get string representation
Public Function ToString(ByVal indent As Integer) As String
    
    Dim strOut As String
    Dim attr As XAttribute
    Dim child As XElement
    
    strOut = Space(indent * 4) & "<" & MyData.Tag
    
    If MyData.Attributes.Count > 0 Then
        For Each attr In MyData.Attributes
            strOut = strOut & " " & attr.Name & "=""" & attr.Value & """"
        Next attr
    End If
    
    If MyData.Children.Count > 0 Then
        strOut = strOut & ">" & vbCrLf
        For Each child In MyData.Children
            strOut = strOut & child.ToString(indent + 1)
        Next child
        strOut = strOut & Space(indent * 4) & "</" & MyData.Tag & ">" & vbCrLf
    Else
        strOut = strOut & "/>" & vbCrLf
    End If
    
    ToString = strOut

End Function

Select Insert/Class Module from the main menu. Copy the following code into the new class module and then rename it XAttribute.

' Class XAttribute definition
Option Explicit

Private Type InstanceData
    Name As String
    Value As String
End Type

Private MyData As InstanceData

' Name property getter
Public Property Get Name() As String

    Name = MyData.Name
    
End Property

' Name property setter
Public Property Let Name(ByVal Value As String)

    MyData.Name = Value
    
End Property

' Value property getter
Public Property Get Value() As String

    Value = MyData.Value
    
End Property

' Value property setter
Public Property Let Value(ByVal Value As String)

    MyData.Value = Value
    
End Property

Select Insert/Module from the main menu (Note: Regular module, not class module). Copy the following code into the new module.

Option Explicit

Sub Test()

    Dim doc As XDocument
    Dim configNo As Integer
    Dim config As XElement
    Dim itemNo As Integer
    Dim item As XElement
    
    Set doc = New XDocument
    doc.Root.Tag = "Root"
    doc.Root.AddAttribute "Name", ""
    
    For configNo = 1 To 4
        
        Set config = New XElement
        config.Tag = "Config"
        config.AddAttribute "type", "Typ" & configNo
        doc.Root.AddChild config
    
        For itemNo = 1 To 4
            
            Set item = New XElement
            item.Tag = "Item"
            item.AddAttribute "Name", "It's a test " & itemNo
            config.AddChild item
            
        Next itemNo
        
    Next configNo
    
    Debug.Print doc.ToString

End Sub

Run and enjoy.