Как разобрать XML с помощью vba

Спасибо за подсказки.

Я не знаю, является ли это лучшим подходом к проблеме или нет, но вот как я добился того, чтобы это сработало. Я ссылался на Microsoft XML, v2.6 dll в моем VBA, а затем следующий фрагмент кода дает мне необходимые значения

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

Это немного сложный вопрос, но кажется, что самый прямой путь-это загрузить документ XML или строку XML через MSXML2.DOMDocument, которая затем позволит вам получить доступ к узлам XML.

Вы можете найти более подробную информацию о MSXML2.DOMDocument на следующих сайтах:

• Манипулирование XML файлами с помощью Excel VBA & Xpath
• MSXML - http://msdn.microsoft.com/en-us/library/ms763742(VS.85).aspx
• Обзор MSXML 4.0

Добавьте справочный проект- > ссылки Microsoft 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").текст не совпадает с selectSingleNode("name").текст

Вы можете использовать запрос 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

Это пример OPML парсера, работающего с FeedDemon 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 должен загружаться каждый раз.

Вот краткий Раздел для анализа файла 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 и вытянуть ее в твердое тело.

Обновление

Процедура, представленная ниже, дает пример синтаксического анализа XML с VBA с использованием объектов XML DOM. Код основан на руководстве для начинающих 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 - этот первоначальный ответ показывает самую простую возможную вещь, которую я мог себе представить (в то время я работал над очень конкретным вопросом) . Естественно, использование XML объектов, встроенных в VBA XML Dom, было бы гораздо лучше. Смотрите обновления выше.

Оригинальный Ответ

Я знаю, что это очень старый пост, но я хотел бы поделиться своим простым решением этого сложного вопроса. В первую очередь я использовал базовые строковые функции для доступа к данным xml.

Это предполагает, что у вас есть некоторые данные xml (в переменной temp), которые были возвращены в функции VBA. Достаточно интересно, что можно также увидеть, как я связываюсь с веб-сервисом xml, чтобы получить значение. Функция, показанная на рисунке, также принимает значение поиска, поскольку эта функция Excel VBA может быть доступна из ячейки с помощью = FunctionName (value1, value2) для возврата значений через веб-сервис в электронную таблицу.

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, когда вы не хотите включать macros. Это можно сделать с помощью функции replace. Введите начальный и конечный узлы в ячейки 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