VBA 在单元格中显示 XML 层次结构
VBA display XML with hierarchy in cells
我正在尝试格式化下面的 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
这是预期的输出
在列中显示 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]
启动一个 递归 调用以在数组 中收集 node/attribute 个字符串
[2]
将结果写入给定的目标范围。
在此示例中,我更喜欢 .Load
示例文件而不是 .LoadXML
内容字符串,以允许用户通过复制 OP 的 XML 内容直接放入测试文件夹,而不是通过 VBA 代码以迂回方式创建此字符串。
此外,xml 是通过 后期绑定 加载的,以允许所有用户进行简单加载;当然,这可以很容易地更改为 early 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://whosebug.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://whosebug.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
我正在尝试格式化下面的 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
这是预期的输出
在列中显示 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]
启动一个 递归 调用以在数组 中收集 node/attribute 个字符串
[2]
将结果写入给定的目标范围。
在此示例中,我更喜欢 .Load
示例文件而不是 .LoadXML
内容字符串,以允许用户通过复制 OP 的 XML 内容直接放入测试文件夹,而不是通过 VBA 代码以迂回方式创建此字符串。
此外,xml 是通过 后期绑定 加载的,以允许所有用户进行简单加载;当然,这可以很容易地更改为 early 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://whosebug.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://whosebug.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