Я работаю в 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 из-за поля, в котором я работаю.
Как это сделать?
Это немного сложный вопрос, но кажется, что наиболее прямым путем будет загрузка XML-документа или XML-строки через MSXML2.DOMDocument, который затем позволит вам получить доступ к узлам XML.
Подробнее о MSXML2.DOMDocument вы можете найти на следующих сайтах:
Спасибо за указатели.
Я не знаю, является ли это наилучшим подходом к проблеме или нет, но вот как я получил ее на работу. Я ссылался на dll Microsoft XML, v2.6 в своем 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
Добавить ссылку Project- > Ссылки 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 node//Root/Person не совпадает с //root/person, также selectSingleNode ( "Name" ). Текст не совпадает с selectSingleNode ( "name" ). text
Вы можете использовать запрос 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:
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 должен быть загружен каждый раз.
Ниже приведен короткий фрагмент для анализа 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 и выдавить его на твердое тело.
Часто проще анализировать без 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
Обновление
Ниже приведена процедура анализа 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-объектов, встроенных в XML-документ VBA, было бы намного лучше. См. Обновления выше.
Оригинальный ответ
Я знаю, что это очень старый пост, но я хотел поделиться своим простым решением с этим сложным вопросом. В основном я использовал основные строковые функции для доступа к данным 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)
XML Parsing code
Option Explicit
Dim Path As String ' input path name
Dim FileName As String ' input file name
Dim intColumnCount As Integer ' column counter
Dim intLoop As Integer ' Looping integer
Dim objDictionary As Scripting.Dictionary ' dictionary object to store column identification for id, method, query string etc
Dim intPrevRequest_id As Integer 'stores previous request id
Dim intCurrRequest_id As Integer 'stores current request id
Dim strWholeReq As String ' Full request that is ready to be written to file
Dim strStartQuotes As String ' Placeholder which holds starting double quotes
Dim strEndQuotes As String ' Placeholder which holds ending double quotes
Dim strStepName As String ' First line of the Parsed_XML_Function. e.g. Parsed_XML_Function("Step5",
'Here 5 comes from intStepNum variable
Dim strUrl As String ' contains URL and Query string
Dim strQueryStr As String ' Query string
Dim strMethod As String ' Method part of request
Dim strBody As String 'Body attributes
Dim strMisc As String ' Misc items such as Resource, Snapshot number etc
Dim strContentType As String ' Content type of request
Dim intStepNum As Integer ' iterative count to identify step
Dim objFileSys As Scripting.FileSystemObject ' file system object
Dim objFile As Scripting.File 'file object
Dim objTextStr As Scripting.TextStream 'text stream object
Dim ActionFileName As String ' destination action name
'this funciton is the main function which calls other functions
Sub Main()
Path = Worksheets(1).Cells(1, 2).Value
FileName = Worksheets(1).Cells(2, 2).Value
ActionFileName = Worksheets(1).Cells(3, 2).Value
'open xml file
Workbooks.Open FileName:=Path & "\" & FileName
'activate the workbook
Windows(FileName).Activate
'delete first row
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Name = "PARSINGVS_XML"
'get total columns and analyze the columns
intColumnCount = Worksheets("PARSINGVS_XML").UsedRange.Columns.Count
Set objDictionary = New Dictionary
intLoop = 1
For intLoop = 1 To intColumnCount
If InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "Request/#id", 1) > 0 Then
objDictionary.Add "Req_id", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "Request/@Method", 1) > 0 Then
objDictionary.Add "Req_method", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "Request/@Url", 1) > 0 Then
objDictionary.Add "Req_url", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "FormPostHttpBody/@ContentType", 1) > 0 Then
objDictionary.Add "Req_contenttype", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "FormPostParameter/@Name", 1) > 0 Then
objDictionary.Add "Req_itemdata_name", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "FormPostParameter/@Value", 1) > 0 Then
objDictionary.Add "Req_itemdata_value", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "QueryStringParameter/@Name", 1) > 0 Then
objDictionary.Add "Req_querystring_name", intLoop
ElseIf InStr(1, Worksheets("PARSINGVS_XML").Cells(1, intLoop), "QueryStringParameter/@Value", 1) > 0 Then
objDictionary.Add "Req_querystring_value", intLoop
End If
Next
'Loop through all requests and capture querysting, itemdata, url, method, action and content type
'-----------------------------------------------
'Initialize variables ot default value at start
'-----------------------------------------------
intPrevRequest_id = 1
intCurrRequest_id = 1
strStartQuotes = """"
strEndQuotes = """," & vbCrLf
intStepNum = 1
strQueryStr = ""
strBody = ""
Set objFileSys = New Scripting.FileSystemObject
objFileSys.CreateTextFile (Path & "\" & ActionFileName)
Set objFile = objFileSys.GetFile(Path & "\" & ActionFileName)
Set objTextStr = objFile.OpenAsTextStream(ForAppending, TristateUseDefault)
intLoop = 2 'first line is the header
For intLoop = 2 To Worksheets("PARSINGVS_XML").UsedRange.Rows.Count
If objDictionary.Exists("Req_id") Then
intCurrRequest_id = Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_id")).Value)
Else
MsgBox "XML do nto contain Request id column"
Exit Sub
End If
'if current and previous request id are not same OR we are at end of steps the write to file
If (intPrevRequest_id <> intCurrRequest_id) Or (intLoop = Worksheets("PARSINGVS_XML").UsedRange.Rows.Count) Then
Call WriteToFile
'iterate to next step
intStepNum = intStepNum + 1
strQueryStr = ""
strBody = ""
intPrevRequest_id = intCurrRequest_id
End If
Call Write_Remaining_DESTINATIONVS_Req ' build the DESTINATIONVS request apart from Body & Query string
Call WriteQuery_Body 'build hte body and querystring
Next
MsgBox "Completed"
Set objDictionary = Nothing
objTextStr.Close
Set objTextStr = Nothing
Set objFile = Nothing
Set objFileSys = Nothing
Windows(FileName).Close (False)
End Sub
'funciton to write contents to file
Sub WriteToFile()
strWholeReq = strWholeReq & vbCrLf & strStepName & strUrl
If strQueryStr <> "" Then
strWholeReq = strWholeReq & "?" & strQueryStr
End If
strWholeReq = strWholeReq & strEndQuotes & strMethod & strContentType & strMisc
If strBody <> "" Then
strWholeReq = strWholeReq & strStartQuotes & "Body=" & strBody & strEndQuotes
End If
strWholeReq = strWholeReq & " LAST);" & vbCrLf
objTextStr.WriteLine strWholeReq
strWholeReq = ""
End Sub
'function to build the querystring and body part which are iterative
Sub WriteQuery_Body()
If objDictionary.Exists("Req_querystring_name") Then
If Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_querystring_name")).Value) <> "" Then
If strQueryStr <> "" Then
strQueryStr = strQueryStr & "&"
End If
'Querystring
strQueryStr = strQueryStr & Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_querystring_name")).Value) & "=" & _
Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_querystring_value")).Value)
End If
End If
If objDictionary.Exists("Req_itemdata_name") Then
If Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_itemdata_name")).Value) <> "" Then
If strBody <> "" Then
strBody = strBody & "&"
End If
'Body
strBody = strBody & Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_itemdata_name")).Value) & "=" & _
Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_itemdata_value")).Value)
End If
End If
End Sub
'function which creates remaining part of web_custom request other than querystring and body
Sub Write_Remaining_DESTINATIONVS_Req()
'Name of Parsed_XML_Function("Step2",
strStepName = "Parsed_XML_Function(" & strStartQuotes & "Step" & intStepNum & strEndQuotes
If objDictionary.Exists("Req_url") Then
'"URL = "
strUrl = strStartQuotes & _
"URL=" & Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_url")).Value)
End If
If objDictionary.Exists("Req_method") Then
'Method =
strMethod = strStartQuotes & _
"Method=" & Trim(Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_method")).Value)) & strEndQuotes
End If
If objDictionary.Exists("Req_contenttype") Then
'ContentType =
If Trim(Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_contenttype")).Value)) <> "" Then
strContentType = strStartQuotes & _
"RecContentType=" & Trim(Trim(Worksheets("PARSINGVS_XML").Cells(intLoop, objDictionary("Req_contenttype")).Value)) & strEndQuotes
Else
strContentType = strStartQuotes & "RecContentType=text/html" & strEndQuotes
End If
Else
strContentType = strStartQuotes & "RecContentType=text/html" & strEndQuotes
End If
'remaining all
strMisc = strStartQuotes & "TargetFrame=" & strEndQuotes & _
strStartQuotes & "Resource=0" & strEndQuotes & _
strStartQuotes & "Referer=" & strEndQuotes & _
strStartQuotes & "Mode=HTML" & strEndQuotes & _
strStartQuotes & "Snapshot=t" & intStepNum & ".inf" & strEndQuotes
End Sub