VBA - RecursiveXmlPrettifier class - recursively prettify all xml files in a subdirectory

So I gave some code to prettify xml content 2017 Q4. With some extra code given here today we can write a class to iterate through a directory and all subdirectories prettifying all the xml files it finds. That is the RecursiveXmlPrettifier class.

The RecursiveXmlPrettifier class

Option Explicit

'Class module RecursiveXmlPrettifier


'*Tools->References
' *** Microsoft Scripting Runtime
' *** Microsoft XML, v6.0


Private mfso As New Scripting.FileSystemObject

Public Sub PrettyPrintAllInFolder(ByVal sFolder As String)

    If mfso.FolderExists(sFolder) Then
    
        PrettyPrintAllTheXmlFilesInThisFolder mfso.GetFolder(sFolder)
    
    End If


End Sub

Private Sub PrettyPrintAllTheXmlFilesInThisFolder(ByVal oFolder As Scripting.Folder)
    
    If Not oFolder Is Nothing Then
    
        Dim oFilLoop As Scripting.File
        For Each oFilLoop In oFolder.Files
            If StrComp(Right$(oFilLoop.Name, 4), ".xml", vbTextCompare) = 0 Then
                PrettifyThisFile oFilLoop.Path
            End If
            
            '* and for bug in Open XML hwerwethere is a file under \xl\_rels called workbook.xml.rels or under \_rels\.rels
            If StrComp(oFolder.Name, "_rels", vbTextCompare) = 0 Then
                If StrComp(oFilLoop.Name, "workbook.xml.rels", vbTextCompare) = 0 Then
                    PrettifyThisFile oFilLoop.Path, True
                End If
            End If
            
            '* or under \xl\_rels called workbook.xml.rels or under \_rels\.rels
            If StrComp(oFolder.Name, "_rels", vbTextCompare) = 0 Then
                If StrComp(oFilLoop.Name, ".rels", vbTextCompare) = 0 Then
                    PrettifyThisFile oFilLoop.Path, True
                End If
            End If
            
        Next oFilLoop
        
        Dim oFolderLoop As Scripting.Folder
        For Each oFolderLoop In oFolder.SubFolders
            
            PrettyPrintAllTheXmlFilesInThisFolder oFolderLoop
        
        Next

    End If

End Sub


Public Sub PrettifyThisFile(ByVal sFile As String, Optional bSkipExtensionCheck As Boolean)

    If Len(sFile) >= 4 Then
    
        Dim bProceed As Boolean
        bProceed = True
        
        '* extra logic to handle Open Xml bug
        If bSkipExtensionCheck = False Then bProceed = StrComp(Right$(sFile, 4), ".xml", vbTextCompare) = 0
        
        If bProceed Then
    
            If mfso.FileExists(sFile) Then
            
                Dim dom As MSXML2.DOMDocument60
                Set dom = New MSXML2.DOMDocument60
                dom.Load sFile
                If dom.parseError.ErrorCode = 0 Then
                    dom.LoadXML PrettyPrintXml(dom)
                    If dom.parseError.ErrorCode = 0 Then
                        dom.Save sFile
                    Else
                        Debug.Print "parse fail on pretttifying"
                    End If
                Else
                    Debug.Print "parse fail on load"
                End If
            
            End If
        End If
    End If

End Sub

Public Function PrettyPrintXml(ByVal dom As MSXML2.DOMDocument60) As String

    Dim reader As MSXML2.SAXXMLReader60
    Set reader = New MSXML2.SAXXMLReader60
    
    Dim writer As MSXML2.MXXMLWriter60
    Set writer = New MSXML2.MXXMLWriter60
    writer.omitXMLDeclaration = True
    writer.indent = True
    
    reader.PutProperty "http://xml.org/sax/properties/lexical-handler", writer

    Set reader.contentHandler = writer
    reader.Parse dom.XML
   
    PrettyPrintXml = writer.output
End Function

The tstTestRecursiveXmlPrettifier standard (test) module

Option Explicit
Option Private Module

'*Tools->References
' *** Microsoft Scripting Runtime
' *** Microsoft XML, v6.0

Private mfso As New Scripting.FileSystemObject

Private Sub TestPrettyPrintAllTheXmlFiles()
    Dim oRecursiveXmlPrettifier As RecursiveXmlPrettifier
    Set oRecursiveXmlPrettifier = New RecursiveXmlPrettifier

    Dim s As String
    s = Environ$("userprofile") & "\AppData\Local\Temp\VBAEquivOfOpenXML\Book1\"
    
    Debug.Assert mfso.FolderExists(s)
    
    oRecursiveXmlPrettifier.PrettyPrintAllInFolder s


End Sub



Private Sub TestPrettifyThisFile()

    Dim oRecursiveXmlPrettifier As RecursiveXmlPrettifier
    Set oRecursiveXmlPrettifier = New RecursiveXmlPrettifier

    Dim s As String
    s = Environ$("userprofile") & "\AppData\Local\Temp\VBAEquivOfOpenXML\Book1\[Content_Types].xml"
    
    Debug.Assert mfso.FileExists(s)
    
    oRecursiveXmlPrettifier.PrettifyThisFile s
    
End Sub

VBA - Ease Xml debugging wth Xml document pretty print

I like Xml and will frequently choose to work with an Xml document carrying data rather than define a ton of type definitions in VBA but this means the Locals and the Watches window show a big blob of a string. So I like to write a function to pretty print the Xml document for output to the Immediate window. Here is it

Option Explicit

Function PrettyPrintXml(ByVal dom As MSXML2.DOMDocument60) As String

    Dim reader As MSXML2.SAXXMLReader60
    Set reader = New MSXML2.SAXXMLReader60
    
    Dim writer As MSXML2.MXXMLWriter60
    Set writer = New MSXML2.MXXMLWriter60
    writer.omitXMLDeclaration = True
    writer.indent = True

    reader.PutProperty "http://xml.org/sax/properties/lexical-handler", writer
    
    Set reader.contentHandler = writer
    reader.Parse dom.XML
   
    PrettyPrintXml = writer.output
End Function

Private Sub TestPrettyPrintXml()

    Dim sSampleXml As String
    sSampleXml = "<note><to>Tove</to><from>Jani</from>" & _
        "<heading>Reminder</heading><body>Don't forget me this weekend!</body></note>"

    Dim dom As MSXML2.DOMDocument60
    Set dom = New MSXML2.DOMDocument60
    dom.LoadXML sSampleXml
    Debug.Assert dom.parseError.ErrorCode = 0
    
    Dim sPrettified As String
    sPrettified = PrettyPrintXml(dom)
    
    Debug.Print sPrettified
    
    Dim vSplitLines As Variant
    vSplitLines = VBA.Split(sPrettified, vbNewLine)
    
    Debug.Assert vSplitLines(0) = ""
    Debug.Assert vSplitLines(1) = vbTab & "Tove"
    Debug.Assert vSplitLines(2) = vbTab & "Jani"
    Debug.Assert vSplitLines(3) = vbTab & "Reminder"
    Debug.Assert vSplitLines(4) = vbTab & "Don't forget me this weekend!"
    Debug.Assert vSplitLines(5) = ""
End Sub