CodeItBetter Programming Another VB Programming Blog

'XML Handling - Indent XML Code
Sub oIndentXml(oXMLfile As String)
    On Error Resume Next
    ''This procedure is used to indent XML document
    '' <Family>
    ''    <Member Relationship="Father">
    ''       <Name>Some Guy</Name>
    ''    </Member>
    '' </Family>
    '' Requires msxml.dll (Go to Project --> References and and choose Microsoft
    '' XML version 2.0, or whatever the
    '' current version you have installed)
    Dim oXSLT As DOMDocument
    Dim XSL_FILE As String
    Dim sResult As String
    Const DoubleQuotes = """"
    Dim strText As String
    Dim objDom As DOMDocument
 
    Set objDom = New DOMDocument
 
    Open oXMLfile For Input As #1
    strText = Input$(LOF(1), #1)
    Close #1
 
    objDom.loadXML strText
 
    Set oXSLT = New DOMDocument
    XSL_FILE = "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes _
        & "UTF-8" & DoubleQuotes & "?>" & vbCrLf & "<xsl:stylesheet version=" & DoubleQuotes & "1.0" _
        & DoubleQuotes & " xmlns:xsl=" & DoubleQuotes & "http://www.w3.org/1999/XSL/Transform" _
        & DoubleQuotes & ">" & vbCrLf & "     <xsl:output method=" & DoubleQuotes & "xml" & DoubleQuotes _
        & " version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" & DoubleQuotes & "UTF-8" _
        & DoubleQuotes & " indent=" & DoubleQuotes & "yes" & DoubleQuotes & "/>" & vbCrLf & _
        "     <xsl:template match=" & DoubleQuotes & "@* | node()" & DoubleQuotes & ">" & vbCrLf & _
        "          <xsl:copy>" & vbCrLf        & "               <xsl:apply-templates select=" & DoubleQuotes & _
        "@* | node()" & DoubleQuotes & " />" & vbCrLf & "          </xsl:copy>" & vbCrLf & "     </xsl:template>" _
        & vbCrLf & "</xsl:stylesheet>"
    objDom.async = False
    oXSLT.async = False
    oXSLT.loadXML XSL_FILE
    If oXSLT.parseError.errorCode = 0 Then
        If oXSLT.readyState = 4 Then
            sResult = objDom.transformNode(oXSLT.documentElement)
            sResult = Replace$(sResult, "<?xml version=" & DoubleQuotes & "1.0" & DoubleQuotes & " encoding=" _
                & DoubleQuotes & "UTF-16" & DoubleQuotes & "?>", vbNullString, , , vbTextCompare)
            objDom.loadXML sResult
        End If
    Else
        Debug.Print Err.Description = oXSLT.parseError.reason & vbCrLf & "Line: " & oXSLT.parseError.Line & vbCrLf _
            & "XML: " & oXSLT.parseError.srcText
        'Err.Raise 1006
        Err.Clear
    End If
 
    strText = objDom.xml
 
    'open the file to save added headers after indenting the code
    Open oXMLfile For Output As #1
    Print #1, strText
    Close #1
 
ExitHere:
    Err.Clear
    Set oXSLT = Nothing
    Set objDom = Nothing
End Sub