Creating XML file from XLS Cells via indentations

Question

What I am trying to do is creating a XML file by parsing a XLS file. An example should be more relevant:

| tag1      |           |           |           |
|           | tag2      |           |           |
|           |           | tag3      | tag3Value |
|           |           | tag4      | tag4Value |
|           | tag5      |           |           |
|           |           | tag6      | tag6Value |
|           |           |           |           |

If we imagine those are cells, will be equivalent for the following .xml code.

<tag1>
    <tag2>
        <tag3> tag3Value </tag3>
        <tag4> tag4Value </tag4>
    </tag2>
    <tag5>
        <tag6> tag6Value </tag6>
    </tag5>
</tag1>

That wouldn't be so hard by managing one cell at a time and just doing "<" & Cell(x,y) & ">" But I wanted an elegant solution. Here is my implementation so far:

Sub lol()
    Sheet1.Activate

    Dim xmlDoc As MSXML2.DOMDocument
    Dim xmlNode As MSXML2.IXMLDOMNode

    Set xmlDoc = New MSXML2.DOMDocument
    createXML xmlDoc
End Sub

Sub createXML(xmlDoc As MSXML2.DOMDocument)
    Dim newNode As MSXML2.IXMLDOMNode

    If Not (Cells(1, 1) = "") Then

        'newNode.nodeName = Cells(1, 1)
        ReplaceNodeName xmlDoc, newNode, Cells(1, 1)

        createXMLpart2 xmlDoc, newNode, 2, 2
        xmlDoc.appendChild newNode
    End If
    xmlDoc.Save "E:\saved_cdCatalog.xml"
End Sub

Sub createXMLpart2(xmlDoc As MSXML2.DOMDocument, node As MSXML2.IXMLDOMElement, i As Integer, j As Integer)
     Dim newNode As MSXML2.IXMLDOMElement
     If Not (Cells(i, j) = "") Then

        If (Cells(i, j + 1) = "") Then

            'newNode.nodeName = Cells(i, j)
            ReplaceNodeName xmlDoc, newNode, Cells(i, j)

            createXMLpart2 xmlDoc, newNode, i + 1, j + 1
        Else
            'newNode.nodeName = "#text"
            ReplaceNodeName xmlDoc, newNode, "#text"

            'newNode.nodeValue = Cells(i, j + 1)
            createXMLpart2 xmlDoc, newNode, i + 1, j
        End If
        node.appendChild (newNode)
    End If
End Sub

Private Sub ReplaceNodeName(oDoc As DOMDocument, oElement As IXMLDOMElement, newName As String)
        Dim ohElement As IXMLDOMElement
        Dim sElement As IXMLDOMElement
        Dim oChild As IXMLDOMNode

        ' search the children '
        If Not oElement Is Nothing Then
                Set ohElement = oElement.parentNode
                Set sElement = oDoc.createElement(newName)

                For Each oChild In oElement.childNodes
                        Call sElement.appendChild(oChild)
                Next

                Call ohElement.replaceChild(sElement, oElement)
        End If
End Sub

Problems: at first I didn't realize that I can't change the name of a node by doing node.nodeName = "newName" I have found a solution on StackOverflow actually: Change NodeName of an XML tag element using MSXML

So i've commented my attempts at renaming the nodes and tried the version with the ReplaceNodeName method.

The actual problem: node.appendChild (newNode) from createXMLpart2 is giving me a problem: it sais that the variable "newNode" is no set. I am puzzled.

Answer 1

Maybe something like this...

Sub Tester()

Dim r As Range
Dim xmlDoc As New MSXML2.DOMDocument
Dim xmlNodeP As MSXML2.IXMLDOMNode
Dim xmlNodeTmp As MSXML2.IXMLDOMNode
Dim bDone As Boolean

    Set r = ActiveSheet.Range("A1")

    Do While Not r Is Nothing

        Set xmlNodeTmp = xmlDoc.createElement(r.Value)
        If Len(r.Offset(0, 1).Value) > 0 Then
            xmlNodeTmp.appendChild xmlDoc.createTextNode(r.Offset(0, 1).Value)
        End If

        If Not xmlNodeP Is Nothing Then
            xmlNodeP.appendChild xmlNodeTmp
        Else
            xmlDoc.appendChild xmlNodeTmp
        End If
        Set xmlNodeP = xmlNodeTmp

        If Len(r.Offset(1, 0).Value) > 0 Then
            Set r = r.Offset(1, 0) 'sibling node
            Set xmlNodeP = xmlNodeP.ParentNode
        ElseIf Len(r.Offset(1, 1).Value) > 0 Then
            Set r = r.Offset(1, 1) 'child node
        Else
            Set r = r.Offset(1, 0)
            Set xmlNodeP = xmlNodeP.ParentNode
            Do While Len(r.Value) = 0
                If r.Column > 1 Then
                    Set r = r.Offset(0, -1)
                    Set xmlNodeP = xmlNodeP.ParentNode
                Else
                    Set r = Nothing
                    Exit Do
                End If
            Loop
        End If

    Loop
    Debug.Print xmlDoc.XML
End Sub