Как анализировать XML с помощью vba

Я работаю в VBA, и хочу разобрать строку например

<PointN xsi_type='typens:PointN' 
 
>
    <X>24.365</X>
    <Y>78.63</Y>
</PointN>

и получить значения X & Y в двух отдельных целочисленных переменных.

Я новичок, когда дело доходит до XML, так как я застрял в VB6 и VBA, из-за области, в которой я работаю.

Как это сделать?

8 ответов

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

    Вы можете найти больше на MSXML2.DOMDocument на следующих сайтах:

  2. Спасибо за указатели.

    Я не знаю, является ли это лучшим подходом к проблеме или нет, но вот как я заставил его работать.
    Я сослался на 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
    
  3. Это пример 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 должен загружаться каждый раз.

  4. Обновить

    Процедура, представленная ниже, дает пример синтаксического анализа 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 для получения значения. Функция, показанная в образе, также принимает значение поиска, потому что эта функция VBA Excel может быть доступна из ячейки с помощью = 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)

  5. Можно использовать запрос XPath:

    Dim objDom As Object        '// DOMDocument
    Dim xmlStr As String, _
        xPath As String
    
    xmlStr = _
        "<PointN xsi_type='typens:PointN' " & _
        " " & _
        "> " & _
        "    <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
    
  6. Вот краткий подраздел для разбора XML-файла MicroStation Triforma, который содержит данные для профилей из конструкционной стали.

    '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 и вытянуть его в твердое тело.

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

  8. Часто легче анализировать без VBA, когда вы не хотите включать макросы. Это можно сделать с помощью функции 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