如何使用 vba 解析 XML答案

【问题标题】：How to parse XML using vba如何使用 vba 解析 XML
【发布时间】：2010-09-05 21:27:43
【问题描述】：

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

<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>

并将 X 和 Y 值放入两个单独的整数变量中。

我是 XML 新手，因为我工作的领域是 VB6 和 VBA。

我该怎么做？

【问题讨论】：

Pedantry：24.365 和 78.63 不是整数。

标签： xml vba parsing xml-parsing

【解决方案1】：

感谢指点。

我不知道这是否是解决问题的最佳方法，但这就是我如何让它发挥作用的方法。我在我的 VBA 中引用了 Microsoft XML，v2.6 dll，然后下面的代码 sn-p，给了我所需的值

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

【讨论】：

当我尝试 debug.print 其中一个点时，我得到一个对象变量或未设置块变量。有什么建议吗？

【解决方案2】：

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

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

【讨论】：

【解决方案3】：

添加参考项目->参考微软XML，6.0，你可以使用示例代码：

    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 不同

【讨论】：

一些问题：为什么路径是//root，而不是/root？如果我的 oSeqNode 中有一个人，我如何子选择 just that person 中的所有？

【解决方案4】：

您可以使用 XPath 查询：

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

【讨论】：

【解决方案5】：

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

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）：

...
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

或更好：

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。

【讨论】：

【解决方案6】：

更新

下面介绍的过程给出了一个使用 XML DOM 对象通过 VBA 解析 XML 的示例。代码基于beginners guide of the XML DOM。

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 - 这个最初的答案显示了我能想象到的最简单的事情（当时我正在处理一个非常具体的问题）。使用内置于 VBA XML Dom 中的 XML 工具自然会是好多了。请参阅上面的更新。

原始回复

我知道这是一篇非常古老的帖子，但我想分享我对这个复杂问题的简单解决方案。我主要使用基本的字符串函数来访问 xml 数据。

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


openTag = ""
closeTag = "" 

' 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)

【讨论】：

【解决方案7】：

这是一个简短的子程序，用于解析包含结构钢形状数据的 MicroStation Triforma XML 文件。

'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 中绘制形状并将其拉伸为实体。

【讨论】：

【解决方案8】：

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

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 将具有您的解析值：

Cell A1: {your XML here}
Cell B1: <X>
Cell C1: </X>
Cell D1: 24.365<X><Y>78.68</Y></PointN>
Cell E1: 24.365

【讨论】：