XML Recursive Tree Walker (1 Viewer)

Option Compare Database
Option Explicit

'============================
'Gemma-The-Husky 2008/9

'a demonstration module to take a well formed xml file, and generate a table showing the hierarchical
'structure of the nodes found, using a recursive algorithm.

'roughly/briefly

'sub parsetree(node)
'if node.haschildren then
'  for each node.child
'     parsetree (node.child)
'else
'  save details of this leafnode (see below)
'end if
'end sub
'
'sub main
'call parsetree(basenode)
'end sub

'the code is then made more complex because i wanted to save various extra
'details with each leaf node, which required some extra variables to be passed to the recursive sub - but the main recursive bit, highlighted in blue is not very long at all, as you will see - remove the blue tags to use it!

'===============================

'the leaf nodes are saved in a table "tblxmlnodes"
'the fields required in that table are

'        recid  - an autonumber
'        nodeparent - the id of the parent node
'        nodename - the name of this node
'        nodechain - the concatenated path of nodes
'        nodelevel - the lebel this node is in the hierarchy of nodes
'        nodeorder - the order in which this node was encountered
'        nodeleaf - a node with no children
'        nodeValue - the value of this node

'note that fixup is a small function not included here to wrap strings, dates, etc correctly to work
'with a sql statement

'the domdocument references are in the MicroSoft Office Web XP Web Components, so just set that reference


Dim oxmldoc As DOMDocument
Dim oNode As IXMLDOMNode
Dim nodesinspected As Long

Sub tryit()
'just replace this with any genuine xml file you have
    Call PARSEFILE_xml_quick("filepath.xml")
End Sub

Sub ParseMe(oNode As IXMLDOMNode, nodename As String, chainname As String, level As Long, parentref As Long)
Dim newnode As IXMLDOMNode
Dim leafnode As Boolean
Dim leaftext As String
Dim s As String
Dim nodecount As Long
Dim recid As Long
    
[COLOR="Blue"]    nodecount = 0
    If oNode.hasChildNodes Then
        For Each newnode In oNode.childNodes
            'the child node is a leaf node, so dont go there, just output it
            If newnode.nodename = "#text" Then
                leafnode = True
                
                'save the node in the gosub stuffnode
                'this returns recid, as the autonumber of the new record
                GoSub stuffnode
            Else
                'the trouble is we are stuffing the current node for each child node!
                nodecount = nodecount + 1
                
                If nodecount = 1 Then
                    leafnode = False
                    
                    'this is not a leafnode, but save it if this is the first time we have seen this node
                    GoSub stuffnode
                End If
                
                Call ParseMe(newnode, newnode.nodename, chainname & "_" & newnode.nodename, level + 1, recid)
            End If
        Next
    End If
    Exit Sub
 [/COLOR]   


stuffnode:
    recid = Nz(DLookup("id", "tblxmlnodes", "nodechain = " & fixup(chainname)), 0)
    If recid > 0 Then
        'we already saved this leaf
        Return
    End If
    
    'else its a new one, so save it
    nodesinspected = nodesinspected + 1
    If leafnode Then
        leaftext = newnode.xml
    Else
        leaftext = ""
    End If
    
    s = "insert into tblXMLNodes " & _
        "(xmlref,nodeparent, nodename,nodechain,nodelevel,nodeorder,nodeleaf,nodevalue) select " & _
        fileref & "," & parentref & "," & fixup(nodename) & "," & fixup(chainname) & "," & level & "," & nodesinspected & "," & leafnode & "," & fixup(leaftext) & ";"
'    MsgBox (s)
    CurrentDb.Execute s
    
'read back the recid of the stuffed node
    recid = Nz(DLookup("id", "tblxmlnodes", "nodechain = " & fixup(chainname)), 0)
    Return
    
End Sub


Sub PARSEFILE_xml_quick(importfile As String)
Dim recid As Long

'accept an xml file, and produce a node analysis

    Set oxmldoc = New DOMDocument

    On Error GoTo fail

    oxmldoc.Load importfile

    If oxmldoc.parseError <> 0 Then
        Call MsgBox("Sorry: The file (" & importfile & ") is NOT a valid xml file. " & vbCrLf & _
            "Please Note, the file may just be an empty file. Please check the file. " & vbCrLf & vbCrLf & _
            "Error: " & oxmldoc.parseError, , "Parsefile Quick")
        Exit Sub
    End If

    On Error GoTo fail
    
    'clear the node table, ready to start again
    CurrentDb.Execute "delete * from tblxmlnodes"

    nodesinspected = 0
    For Each oNode In oxmldoc.childNodes
        Call ParseMe(oNode, oNode.nodename, "Base", 0, 0)
    Next
    Call MsgBox("Tree Produced - " & nodesinspected & " nodes")

exithere:
    Exit Sub

fail:
    Call MsgBox("Error Analysing XML File " & vbCrLf & vbCrLf & _
        "Error: " & err & "  Desc: " & err.Description)
    Resume exithere

End Sub

Function fixup(myvar) As Variant
Const quote = """"

Select Case VarType(myvar)
Case vbInteger, vbSingle, vbDouble, vbLong, vbCurrency:
    fixup = CStr(myvar)
Case vbString:
    fixup = quote & Nz(myvar, vbNullString) & quote
Case vbDate:
    fixup = "#" & Format(Nz(myvar, 0), "LOng Date") & "#"
Case Else
    fixup = Null
End Select
End Function