[英]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 的列引用(假設也包括頂級節點 ~~> 即 Level 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 是通過后期綁定加載的,以便所有用戶都能輕松加載; 當然,這可以很容易地更改為早期綁定。
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
遞歸 function 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
幫助 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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.