如何使用VBA解析XML

How to parse XML using vba

我在VBA中工作，并且想解析一个字符串，例如

1
2
3
4
5
6

并将X和Y值分成两个单独的整数变量。

在XML方面，我是一个新手，因为我从事的领域不多，所以我仍停留在VB6和VBA中。

我该怎么做呢？

感谢您的指导。

我不知道这是否是解决问题的最佳方法，但这是我如何使它起作用的方法。
我在VBA中引用了Microsoft XML，v2.6 dll，然后下面的代码段为我提供了所需的值

1
2
3
4
5
6
7
8
9
10
11
12
13

Dim objXML As MSXML2.DOMDocument

Set objXML = New MSXML2.DOMDocument

If Not objXML.loadXML(strXML) Then 'strXML is the string with XML'
Err.Raise objXML.parseError.ErrorCode, , objXML.parseError.reason
End If

Dim point As IXMLDOMNode
Set point = objXML.firstChild

Debug.Print point.selectSingleNode("X").Text
Debug.Print point.selectSingleNode("Y").Text

这是一个复杂的问题，但是似乎最直接的方法是通过MSXML2.DOMDocument加载XML文档或XML字符串，然后使您可以访问XML节点。

您可以在以下站点上找到有关MSXML2.DOMDocument的更多信息：

使用Excel VBA和Xpath处理XML文件
MSXML-http://msdn.microsoft.com/zh-CN/library/ms763742(VS.85).aspx
MSXML 4.0概述

您可以使用XPath查询：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28

Dim objDom As Object '// DOMDocument
Dim xmlStr As String, _
xPath As String

xmlStr = _
"<PointN xsi:type='typens:PointN'" & _
"xmlns:xsi='http://www.w3.org/2001/XMLSchema-instance'" & _
"xmlns:xs='http://www.w3.org/2001/XMLSchema'>" & _
" <X>24.365</X>" & _
" <Y>78.63</Y>" & _
"</PointN>"

Set objDom = CreateObject("Msxml2.DOMDocument.3.0") '// Using MSXML 3.0

'/* Load XML */
objDom.LoadXML xmlStr

'/*
' * XPath Query
' */

'/* Get X */
xPath ="/PointN/X"
Debug.Print objDom.SelectSingleNode(xPath).text

'/* Get Y */
xPath ="/PointN/Y"
Debug.Print objDom.SelectSingleNode(xPath).text

添加参考Project-> References Microsoft XML，6.0，您可以使用示例代码：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

Dim xml As String

xml ="<root><person><name>Me </name> </person> <person> <name>No Name </name></person></root>"
Dim oXml As MSXML2.DOMDocument60
Set oXml = New MSXML2.DOMDocument60
oXml.loadXML xml
Dim oSeqNodes, oSeqNode As IXMLDOMNode

Set oSeqNodes = oXml.selectNodes("//root/person")
If oSeqNodes.length = 0 Then
'show some message
Else
For Each oSeqNode In oSeqNodes
Debug.Print oSeqNode.selectSingleNode("name").Text
Next
End If

小心xml节点// root / Person与// root / person不同，selectSingleNode(" Name")。text和selectSingleNode(" name")。text不同

这是使用FeedDemon opml文件的OPML解析器示例：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

Sub debugPrintOPML()

' http://msdn.microsoft.com/en-us/library/ms763720(v=VS.85).aspx
' http://msdn.microsoft.com/en-us/library/system.xml.xmlnode.selectnodes.aspx
' http://msdn.microsoft.com/en-us/library/ms256086(v=VS.85).aspx ' expressions
' References: Microsoft XML

Dim xmldoc As New DOMDocument60
Dim oNodeList As IXMLDOMSelection
Dim oNodeList2 As IXMLDOMSelection
Dim curNode As IXMLDOMNode
Dim n As Long, n2 As Long, x As Long

Dim strXPathQuery As String
Dim attrLength As Byte
Dim FilePath As String

FilePath ="rss.opml"

xmldoc.Load CurrentProject.Path &"" & FilePath

strXPathQuery ="opml/body/outline"
Set oNodeList = xmldoc.selectNodes(strXPathQuery)

For n = 0 To (oNodeList.length - 1)
Set curNode = oNodeList.Item(n)
attrLength = curNode.Attributes.length
If attrLength > 1 Then ' or 2 or 3
Call processNode(curNode)
Else
Call processNode(curNode)
strXPathQuery ="opml/body/outline[position() =" & n + 1 &"]/outline"
Set oNodeList2 = xmldoc.selectNodes(strXPathQuery)
For n2 = 0 To (oNodeList2.length - 1)
Set curNode = oNodeList2.Item(n2)
Call processNode(curNode)
Next
End If
Debug.Print"----------------------"
Next

Set xmldoc = Nothing

End Sub

Sub processNode(curNode As IXMLDOMNode)

Dim sAttrName As String
Dim sAttrValue As String
Dim attrLength As Byte
Dim x As Long

attrLength = curNode.Attributes.length

For x = 0 To (attrLength - 1)
sAttrName = curNode.Attributes.Item(x).nodeName
sAttrValue = curNode.Attributes.Item(x).nodeValue
Debug.Print sAttrName &" =" & sAttrValue
Next
Debug.Print"-----------"

End Sub

这需要文件夹的多层树(Awasu，NewzCrawler)：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72

...
Call xmldocOpen4
Call debugPrintOPML4(Null)
...

Dim sText4 As String

Sub debugPrintOPML4(strXPathQuery As Variant)

Dim xmldoc4 As New DOMDocument60
'Dim xmldoc4 As New MSXML2.DOMDocument60 ' ?
Dim oNodeList As IXMLDOMSelection
Dim curNode As IXMLDOMNode
Dim n4 As Long

If IsNull(strXPathQuery) Then strXPathQuery ="opml/body/outline"

' http://msdn.microsoft.com/en-us/library/ms754585(v=VS.85).aspx
xmldoc4.async = False
xmldoc4.loadXML sText4
If (xmldoc4.parseError.errorCode <> 0) Then
Dim myErr
Set myErr = xmldoc4.parseError
MsgBox ("You have error" & myErr.reason)
Else
' MsgBox xmldoc4.xml
End If

Set oNodeList = xmldoc4.selectNodes(strXPathQuery)

For n4 = 0 To (oNodeList.length - 1)
Set curNode = oNodeList.Item(n4)
Call processNode4(strXPathQuery, curNode, n4)
Next

Set xmldoc4 = Nothing

End Sub

Sub processNode4(strXPathQuery As Variant, curNode As IXMLDOMNode, n4 As Long)

Dim sAttrName As String
Dim sAttrValue As String
Dim x As Long

For x = 0 To (curNode.Attributes.length - 1)
sAttrName = curNode.Attributes.Item(x).nodeName
sAttrValue = curNode.Attributes.Item(x).nodeValue
'If sAttrName ="text"
Debug.Print strXPathQuery &" ::" & sAttrName &" =" & sAttrValue
'End If
Next
Debug.Print""

If curNode.childNodes.length > 0 Then
Call debugPrintOPML4(strXPathQuery &"[position() =" & n4 + 1 &"]/" & curNode.nodeName)
End If

End Sub

Sub xmldocOpen4()

Dim oFSO As New FileSystemObject ' Microsoft Scripting Runtime Reference
Dim oFS
Dim FilePath As String

FilePath ="rss_awasu.opml"
Set oFS = oFSO.OpenTextFile(CurrentProject.Path &"" & FilePath)
sText4 = oFS.ReadAll
oFS.Close

End Sub

或更好：

1
2
3
4
5
6
7
8
9
10
11
12

Sub xmldocOpen4()

Dim FilePath As String

FilePath ="rss.opml"

' function ConvertUTF8File(sUTF8File):
' http://www.vbmonster.com/Uwe/Forum.aspx/vb/24947/How-to-read-UTF-8-chars-using-VBA
' loading and conversion from Utf-8 to UTF
sText8 = ConvertUTF8File(CurrentProject.Path &"" & FilePath)

End Sub

但我不明白，为什么每次都应加载xmldoc4。

这是解析MicroStation Triforma XML文件的简短子内容，该XML文件包含钢结构形状的数据。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36

'location of triforma structural files
'c:\programdata\bentley\workspace\triforma\tf_imperial\data\us.xml

Sub ReadTriformaImperialData()
Dim txtFileName As String
Dim txtFileLine As String
Dim txtFileNumber As Long

Dim Shape As String
Shape ="w12x40"

txtFileNumber = FreeFile
txtFileName ="c:\programdata\bentley\workspace\triforma\tf_imperial\data\us.xml"

Open txtFileName For Input As #txtFileNumber

Do While Not EOF(txtFileNumber)
Line Input #txtFileNumber, txtFileLine
If InStr(1, UCase(txtFileLine), UCase(Shape)) Then
P1 = InStr(1, UCase(txtFileLine),"D=")
D = Val(Mid(txtFileLine, P1 + 3))

P2 = InStr(1, UCase(txtFileLine),"TW=")
TW = Val(Mid(txtFileLine, P2 + 4))

P3 = InStr(1, UCase(txtFileLine),"WIDTH=")
W = Val(Mid(txtFileLine, P3 + 7))

P4 = InStr(1, UCase(txtFileLine),"TF=")
TF = Val(Mid(txtFileLine, P4 + 4))

Close txtFileNumber
Exit Do
End If
Loop
End Sub

在这里，您可以使用这些值在MicroStation 2d中绘制形状或在3d中进行绘制并将其拉伸为实体。

更新资料

下面介绍的过程提供了一个使用XML DOM对象使用VBA解析XML的示例。代码基于XML DOM的初学者指南。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

Public Sub LoadDocument()
Dim xDoc As MSXML.DOMDocument
Set xDoc = New MSXML.DOMDocument
xDoc.validateOnParse = False
If xDoc.Load("C:\My Documents\sample.xml") Then
' The document loaded successfully.
' Now do something intersting.
DisplayNode xDoc.childNodes, 0
Else
' The document failed to load.
' See the previous listing for error information.
End If
End Sub

Public Sub DisplayNode(ByRef Nodes As MSXML.IXMLDOMNodeList, _
ByVal Indent As Integer)

Dim xNode As MSXML.IXMLDOMNode
Indent = Indent + 2

For Each xNode In Nodes
If xNode.nodeType = NODE_TEXT Then
Debug.Print Space$(Indent) & xNode.parentNode.nodeName & _
":" & xNode.nodeValue
End If

If xNode.hasChildNodes Then
DisplayNode xNode.childNodes, Indent
End If
Next xNode
End Sub

Nota Bene - This initial answer shows the simplest possible thing I could imagine (at the time I was working on a very specific issue) .
Naturally using the XML facilities built into the VBA XML Dom would be
much better. See the updates above.

原始回应

我知道这是一篇很老的文章，但是我想分享我对这个复杂问题的简单解决方案。最初，我已经使用基本的字符串函数来访问xml数据。

假设您已经在VBA函数中返回了一些xml数据(在temp变量中)。有趣的是，还可以看到我如何链接到xml Web服务以检索值。图像中显示的函数也需要一个查找值，因为可以使用= FunctionName(value1，value2)从单元格中访问此Excel VBA函数，以通过Web服务将值返回到电子表格中。

sample function

1
2
3
4
5
6
7
8

openTag ="<" & tagValue &">"
closeTag ="< /" & tagValue &">"
' Locate the position of the enclosing tags
startPos = InStr(1, temp, openTag)
endPos = InStr(1, temp, closeTag)
startTagPos = InStr(startPos, temp,">") + 1
' Parse xml for returned value
Data = Mid(temp, startTagPos, endPos - startTagPos)

当您不想启用宏时，通常在没有VBA的情况下更容易解析。这可以通过替换功能来完成。在单元格B1和C1中输入起始节点和结束节点。

1
2
3
4
5

Cell A1: {your XML here}
Cell B1: <X>
Cell C1: </X>
Cell D1: =REPLACE(A1,1,FIND(A2,A1)+LEN(A2)-1,"")
Cell E1: =REPLACE(A4,FIND(A3,A4),LEN(A4)-FIND(A3,A4)+1,"")

结果行E1将具有您解析的值：

1
2
3
4
5