How to parse XML with vba

Question

I work in VBA and want to parse a string like

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

and get the values ​​of X and Y into two separate integer variables.

I am new when it comes to XML, as I am stuck in VB6 and VBA because of the field I work in.

How to do it?

Answer 1

This is a bit of a tricky question, but it seems that the most direct way is to load an XML document or XML string through MSXML2.DOMDocument, which then allows you to access the XML nodes.

You can find more information about MSXML2.DOMDocument on the following sites:

• Manipulating XML files with Excel VBA and Xpath
• MSXML - http://msdn.microsoft.com/en-us/library/ms763742(VS.85).aspx
• MSXML 4.0 Overview

Answer 2

Thanks for the pointers.

I don’t know if this is the best approach to the problem or not, but here is how I got it to work. I referenced the Microsoft XML dll, v2.6 in my VBA, and then the following code snippet gives me the required values

 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 

Answer 3

Add the link Project-> Microsoft XML Links, 6.0 and you can use the sample code:

  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 

be careful with xml node // Root / Person does not match // root / person, also selectSingleNode ("Name"). The text does not match selectSingleNode ("name"). text

Answer 4

You can use the XPath query:

 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 

Answer 5

This is an example of an OPML parser working with FeedDemon file files:

 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 

This accepts multi-level folder trees (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 

or better:

 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 

but I do not understand why xmldoc4 should be loaded every time.

Answer 6

Below is a short snippet for parsing the MicroStation Triforma XML file, which contains structural steel mold data.

 '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 

Here you can use the values ​​to draw a figure in MicroStation 2d or do it in 3d and extrude it onto a solid.

Answer 7

Update

The following is a procedure for parsing XML using VBA using XML DOM objects. The code is based on the XML DOM Starter Guide .

 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 thing I could imagine (while I was working on a very specific problem). Naturally, using XML objects embedded in a VBA XML document would be much better. See Updates above.

Original answer

I know this is a very old post, but I wanted to share my simple solution with this difficult question. I mainly used basic string functions to access xml data.

This assumes that you have some XML data (in the temp variable) that was returned in the VBA functions. Interestingly, you can also see how I contact the xml web service to get the value. The function shown in the image also accepts a search value, since this Excel VBA function is accessible from inside the cell using = FunctionName (value1, value2) to return values ​​through the web service to the spreadsheet.

 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) 

Answer 8

It's often easier to parse without VBA when you don't want to include macros. This can be done using the replace function. Enter the start and end nodes in cells B1 and 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,"") 

And the result string E1 will have your parsed value:

 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 

Answer 9

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