VBA 在单元格中显示具有层次结构的 XML

Question

我正在尝试将以下 XML 格式化为以与它显示的相同层次结构方式打印。 第一个单元格中的父节点，在下一行，第二列第一个子节点及其属性（如果有）及其后续行中的子节点。 这是我的 XML：

<ResponseEnvelope xmlns="http://www.nwabcdfdfd.com/messagin" xmlns:xsd="http://www.w3.org/2001/XMLSchema" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
   <ResponseHeader>
      <RequestId>directv_99e0857d-abf3-461c-913e-3ab59c6b5ef6</RequestId>
      <ResponseId>1162969</ResponseId>
      <MessageVersion>1.10</MessageVersion>
      <RequestTimestamp>2013-02-12T17:26:28.172Z</RequestTimestamp>
      <ResponseTimestamp>2013-02-12T17:26:50.409Z</ResponseTimestamp>
      <SenderId>CarePortal2</SenderId>
      <ProgramName />
      <TestProdFlag>P</TestProdFlag>
      <ResultCode>9</ResultCode>
      <Locale>en_US</Locale>      
     <Error>
        <ErrorCode>9</ErrorCode>
        <ErrorNumber>90001</ErrorNumber>
        <ErrorMessage>System error occurred</ErrorMessage>
        <ErrorFieldId />
     </Error>      
   </ResponseHeader>
   <ResponseBody xsi:type="CPSingleSignOnResponse">
      <PortalUserID>45497</PortalUserID>
      <PartyID>1858186</PartyID>
      <WarrantyItemName>DTV ABC WOLE HE P</WarrantyItemName>
      <WarrantyInventoryItemId>138677</WarrantyInventoryItemId>
      <ClientWarrantySku>202</ClientWarrantySku>          
      <Customer type="primary">
         <PartyId>185812386</PartyId>
         <Salutation />
         <FirstName>XXXX</FirstName>
         <LastName>Tanna</LastName>         
            <Address type="current">
               <PartySiteId>3617490</PartySiteId>
               <Type>BILTO</Type>
               <Address1>CASCADES</Address1>
               <Address2>202</Address2>
               <Address3>RIDGE HEAVEN</Address3>
               <Address4 />
               <City>STERLING</City>
               <State>VA</State>
               <PostalCode>20165</PostalCode>
               <County>LOUDOUN</County>
               <Province />
               <Country>US</Country>
               <Urbanization />
               <AddressStyle>US</AddressStyle>
            </Address>                          
      </Customer>
   </ResponseBody>
</ResponseEnvelope>

这是我开发的用于仅在下一行和相邻单元格中打印的代码。但我需要的是附图中的 代码：

Sub Write_XML_To_Cells(ByVal Response_Data As String)
    Dim rXml        As MSXML2.DOMDocument60
    Set rXml = New MSXML2.DOMDocument60
    rXml.LoadXML Response_Data
    
    Dim i           As Integer
    Dim Start_Col As Integer
    i = 3
    Set oParentNode = rXml.DocumentElement
    Call List_ChildNodes(oParentNode, i)
End Sub
Sub List_ChildNodes(oParentNode, i)
    Dim X_sheet     As Worksheet
    Set X_sheet = Sheets("DTAppData | Auditchecklist")
    Dim Node_Set As Boolean
    For Each oChildNode In oParentNode.ChildNodes
        Node_Set = False
        Err.Clear
        On Error Resume Next
        
        If Not ((oChildNode.BaseName & vbNullString) = vbNullString) Then
            Node_Set = True
            If Not IsNull(oChildNode.Attributes) And oChildNode.Attributes.Length > 0 Then
                X_sheet.Cells(i, 1) = oChildNode.BaseName
                For Each Atr In oChildNode.Attributes
                   'Attributes in concatenation 
                    X_sheet.Cells(i, 2) = X_sheet.Cells(i, 2) & " " & Atr.XML
                Next
                    i = i + 1
            Else
                 X_sheet.Cells(i, 1) = oChildNode.BaseName
                 i = i + 1
            End If
         End If
         
        If oChildNode.ChildNodes.Length > 1 Then
            For Each oChildNode1 In oChildNode.ChildNodes
                Call List_ChildNodes(oChildNode1, i)
            Next
        Else
            If ((oChildNode.tagName & vbNullString) = vbNullString) Then
                X_sheet.Cells(i, 1) = oChildNode.ParentNode.nodeName
                X_sheet.Cells(i, 2) = oChildNode.ParentNode.Text
                i = i + 1
            Else
                If Not ((oChildNode.Text & vbNullString) = vbNullString) Then
                    X_sheet.Cells(i, 1) = oChildNode.tagName
                    X_sheet.Cells(i, 2) = oChildNode.Text
                    i = i + 1
                Else
                    X_sheet.Cells(i, 1) = oChildNode.tagName
                    i = i + 1
                End If
            End If
        End If
    Next
End Sub

这是预期的输出

Answer 1

在列中显示 XML 层次结构

因为@Pat 需要一个列表

• 节点名称按照其层次结构级别的顺序出现在后续列中，
• 右下列中的文本节点值和
• 最后一列中的属性定义，

我在顶部添加了一个枚举，以方便接近 OP 的列引用（假设包括顶级节点 ~~> 也就是 0 级）。

Option Explicit                     ' declaration head of code module
Public Enum col
    LEVELS = 4                      ' << maximum count of hierarchy levels
    val1
    val2
End Enum

主要程序

• [1] 开始递归调用以收集数组中的节点/属性字符串
• [2] 将结果写入给定的目标范围。

在此示例中，我更喜欢 .Load 示例文件而不是 .LoadXML 内容字符串，以允许用户通过将 OP 的 XML 内容直接复制到测试文件夹而不是通过通过 VBA 代码以迂回的方式创建此字符串。

此外，xml 是通过 late binding 加载的，以允许所有用户进行简单的加载；当然，这可以很容易地更改为早期绑定。

Sub DisplayXML()

    Dim xFileName As String
    xFileName = ThisWorkbook.Path & "\xml\hierarchy.xml"  ' << change to your needs
    
    Dim xDoc As Object
    Set xDoc = CreateObject("MSXML2.DOMDocument.6.0")

    xDoc.Async = False
    xDoc.ValidateOnParse = False
    Debug.Print xDoc.XML

    If xDoc.Load(xFileName) Then
        ' [1] write xml info to array with exact or assumed items count
        Dim v As Variant: ReDim v(1 To xDoc.SelectNodes("//*").Length, 1 To col.LEVELS + 3)
        '     start call of recursive function
        listChildNodes xDoc.DocumentElement, v ' call help function listChildNodes

        ' [2] write results to target sheet                 ' << change to your sheet name
        With ThisWorkbook.Worksheets("DTAppData | Auditchecklist")
            Dim r As Long, c As Long
            r = UBound(v): c = UBound(v, 2)
            .Range("A1").Resize(r, c) = ""                  ' clear result range
            .Range("A1").Resize(1, c) = Split("Level 0, Level 1,Level 2, Level 3, Level 4,Value 1 (Node),Value 2 (Attribute)", ",") ' titles
            .Range("A2").Resize(r, c) = v ' get  2-dim info array
        End With
    Else
        MsgBox "Load Error " & xFileName
    End If
    Set xDoc = Nothing
End Sub

递归函数listChildNodes()

Function listChildNodes(oCurrNode As Object, _
                        ByRef v As Variant, _
                        Optional ByRef i As Long = 1, _
                        Optional nLvl As Long = 0 _
                        ) As Boolean
' Purpose: assign the complete node structure with contents to a 1-based 2-dim array
' Author:  https://stackoverflow.com/users/6460297/t-m
' Date:    2018-08-19
' Note: Late binding XML doesn't allow the use of IXMLDOMNodeType enumeration constants
'       (1 ... NODE_ELEMENT, 2 ... NODE_ATTRIBUTE, 3 ... NODE_TEXT etc.)
' Escape
  If oCurrNode Is Nothing Then Exit Function
  If i < 1 Then i = 1                                       ' one based items Counter
' Edit 2018-08-20 - Automatic increase of array size if needed
  If i >= UBound(v) Then                                    ' change array size if needed
     Dim tmp As Variant
     tmp = Application.Transpose(v)                         ' change rows to columns
     ReDim Preserve tmp(1 To col.LEVELS + 3, 1 To UBound(v) + 1000)    ' increase row numbers
     v = Application.Transpose(tmp)                         ' transpose back
     Erase tmp
  End If

' Declare variables
  Dim oChildNode As Object                                  ' late bound node object
  Dim bDisplay   As Boolean
' ---------------------------------------------------------------------
' A. It's nothing but a TextNode (i.e. a parent node's firstChild!)
' ---------------------------------------------------------------------
If (oCurrNode.NodeType = 3) Then                            ' 3 ... NODE_TEXT
  ' display pure text content (NODE_TEXT) of parent elements
    v(i, col.val1 + 1) = oCurrNode.Text                     ' nodeValue of text node
  ' return
    listChildNodes = True
ElseIf oCurrNode.NodeType = 1 Then                          ' 1 ... NODE_ELEMENT
   ' --------------------------------------------------------------
   ' B.1 NODE_ELEMENT WITHOUT text node immediately below,
   '     a) e.g. <Details> followed by node element <NAME>,
   '        (i.e. FirstChild.NodeType must not be of type NODE_TEXT = 3)
   '     b) e.g. <College> node element without any child node
   '     Note: a text content (NODE_TEXT) actually is a child node(!) to an element node
   '           (see section A. getting the FirstChild of a NODE_ELEMENT)
   ' --------------------------------------------------------------
   ' a) display parent elements of other element nodes
     If oCurrNode.HasChildNodes Then
         If Not oCurrNode.FirstChild.NodeType = 3 Then      ' <>3 ... not a NODE_TEXT
            bDisplay = True
         End If
   ' b) always display empty node elements
     Else                                                   ' empty NODE_ELEMENT
            bDisplay = True
     End If
     If bDisplay Then
            v(i, nLvl + 1) = oCurrNode.nodename
            v(i, col.val2 + 1) = getAtts(oCurrNode)
            i = i + 1
     End If

   ' --------------------------------------------------------------
   ' B.2 check child nodes
   ' --------------------------------------------------------------
     For Each oChildNode In oCurrNode.ChildNodes
      ' ~~~~~~~~~~~~~~~~~
      ' recursive call <<
      ' ~~~~~~~~~~~~~~~~~
        bDisplay = listChildNodes(oChildNode, v, i, nLvl + 1)

        If bDisplay Then
            v(i, nLvl + 1) = oCurrNode.nodename
            v(i, col.val2 + 1) = getAtts(oCurrNode)
            i = i + 1
        End If
     Next oChildNode
   ' return
     listChildNodes = False

Else    ' just to demonstrate the use of other xml types as e.g. <!-- comments -->
     If oCurrNode.NodeType = 8 Then   ' 8 ... NODE_COMMENT
        v(i, nLvl + 1) = "<!-- " & oCurrNode.NodeValue & "-->"
        i = i + 1
     End If
   ' return
     listChildNodes = False
End If

End Function

帮助功能getAtts()

Function getAtts(ByRef node As Object) As String
' Purpose: return attribute(s) string, e.g. 'type="primary"]'
' Note:    called by above function listChildNodes()
' Author:  https://stackoverflow.com/users/6460297/t-m
  Dim sAtts as String, ii As Long
  If node.Attributes.Length > 0 Then
      ii = 0: sAtts = ""
      For ii = 0 To node.Attributes.Length - 1
        sAtts = sAtts & "" & node.Attributes.Item(ii).nodename & "=""" & node.Attributes.Item(ii).NodeValue & """ "
      Next ii
  End If
' return
  getAtts = sAtts
End Function