Consuming OData with Office VBA - Part II
In case the title didn't give the fact away, this is the second part of a series - the first part is here. This post builds on the code from that post, so make sure you've gone over that before continuing.
Last time, we simply got an XML document in the form of a DOMDocument object, and wrote out the XML to a Microsoft Word document.
This time, we'll take the XML document and put it into a format that makes it easier to use. We'll simplify things a lot and leave out some of the implementation that we're not concerned with now - I want something that is very easy to use. We'll just grab each entry or record and put it into a dictionary of name/value pairs, and we'll turn a feed into a collection of these dictionaries. This provides a nice representation for the data that we can then work with.
Without further ado, this is the function we'll call to turn our feed into a collection of objects.
' Given an OData feed document, reads the entries into a Collection.
Function ODataReadFeed(ByVal objFeed As MSXML2.IXMLDOMElement) As Collection
Dim objResult As Collection
Dim objChild As MSXML2.IXMLDOMNode
Set objResult = New Collection
Set objChild = objFeed.FirstChild
While Not objChild Is Nothing
If objChild.NodeType = NODE_ELEMENT And _
objChild.NamespaceURI = AtomNamespace And _
objChild.baseName = "entry" Then
objResult.Add ODataReadEntry(objChild)
End If
Set objChild = objChild.NextSibling
Wend
Set ODataReadFeed = objResult
End Function
This function simply looks for 'entry' elements in the XML and then processes those.
' Given an OData entry element, reads the properties into a dictionary.
Private Function ODataReadEntry(ByVal objEntry As MSXML2.IXMLDOMElement) As Scripting.Dictionary
Dim objResult As Scripting.Dictionary
Dim objChild As MSXML2.IXMLDOMNode
Dim baseName As String
Set objResult = New Scripting.Dictionary
Set objChild = objEntry.FirstChild
While Not objChild Is Nothing
If objChild.NodeType = NODE_ELEMENT And _
objChild.NamespaceURI = AtomNamespace Then
baseName = objChild.baseName
If baseName = "id" Or baseName = "title" Or baseName = "updated" Then
objResult.Add "odata_" & baseName, objChild.Text
ElseIf baseName = "link" Then
' TODO: handle this element as necessary
ElseIf baseName = "category" Then
' TODO: handle this element as necessary
ElseIf baseName = "author" Then
' TODO: handle this element as necessary
ElseIf baseName = "content" Then
ODataReadContent objChild, objResult
End If
End If
Set objChild = objChild.NextSibling
Wend
Set ODataReadEntry = objResult
End Function
As you can see, for each entry we create a dictionary. Right now we're mostly interested in the properties that come in the content of the entry, so again we'll mostly rely on another helper function.
' Given an OData 'content' element, reads the properties into the specified dictionary.
Private Sub ODataReadContent( _
ByVal objContent As MSXML2.IXMLDOMElement, _
ByVal objEntryDictionary As Scripting.Dictionary)
Dim objChild As MSXML2.IXMLDOMElement
Dim objProperties As MSXML2.IXMLDOMElement
' Look for the m:properties element.
Set objProperties = Nothing
Set objChild = objContent.FirstChild
While Not objChild Is Nothing
If objChild.NodeType = NODE_ELEMENT And _
objChild.NamespaceURI = ODataMetadataNamespace And _
objChild.baseName = "properties" Then
Set objProperties = objChild
End If
Set objChild = objChild.NextSibling
Wend
' Read all properties from the m:properties element.
If Not objProperties Is Nothing Then
Set objChild = objProperties.FirstChild
While Not objChild Is Nothing
' TODO: handle null properties and complex types
If objChild.NodeType = NODE_ELEMENT And _
objChild.NamespaceURI = ODataNamespace Then
objEntryDictionary.Add objChild.baseName, objChild.Text
End If
Set objChild = objChild.NextSibling
Wend
End If
End Sub
Throughout, we've been referencing some XML namespaces that help us distinguish regular ATOM elements from actual data or simple metadata. Let's declare those together with the other constants from the last post.
' Error codes from the first sample:
Const ODataErrorFirst As Long = 100
Const ODataCannotReadUrlError As Long = ODataErrorFirst + 1
Const ODataParseError As Long = ODataErrorFirst + 2
' XML namespaces:
Const AtomNamespace As String = "https://www.w3.org/2005/Atom"
Const ODataNamespace As String = "https://schemas.microsoft.com/ado/2007/08/dataservices"
Const ODataMetadataNamespace As String = "https://schemas.microsoft.com/ado/2007/08/dataservices/metadata"
Now all we need to do is put the old function ODataReadUrl together with our new ODataReadFeed function, and then we can go format the results or do whatever we want with them.
Public Sub Sample2()
Dim objDocument As MSXML2.DOMDocument60
Dim objEntries As Collection
Dim strUrl As String
' Read the document with data.
strUrl = "https://ogdi.cloudapp.net/v1/gsa/ConusPerDiemRates2009/"
Set objDocument = ODataReadUrl(strUrl)
' Create a collection of dictionaries with name/value pairs.
Set objEntries = ODataReadFeed(objDocument.DocumentElement)
' Prepare for updating and clear the document.
Application.ScreenUpdating = False
ActiveDocument.Content.Delete
ActiveDocument.Content.Style = Styles("Normal")
ActiveDocument.Content.ListFormat.RemoveNumbers
' Build a bulleted list for each state.
Dim objEntry As Scripting.Dictionary
Dim objRange As Range
Dim strText As String
Dim strLastState As String
Set objRange = ActiveDocument.Range(0, 0)
For Each objEntry In objEntries
If objEntry("state") = "" Then
' Special message.
objRange.Text = objEntry("primarydestination") & _
" (" & objEntry("total") & ")"
objRange.InsertParagraphAfter
Else
' Write the state out only if different from the last.
If strLastState <> objEntry("state") Then
strLastState = objEntry("state")
objRange.Text = objEntry("state")
objRange.InsertParagraphAfter
objRange.Style = Styles("Heading 2")
objRange.SetRange objRange.End + 1, objRange.End + 1
End If
strText = objEntry("primarydestination") & ": " _
& objEntry("total")
If objEntry("seasonbegindate") <> "" Then
strText = strText & " (between " & _
Left(objEntry("seasonbegindate"), 10) & _
" and " & Left(objEntry("seasonenddate"), 10) & ")"
End If
objRange.Text = strText
objRange.InsertParagraphAfter
objRange.ListFormat.ApplyBulletDefault
End If
objRange.SetRange objRange.End + 1, objRange.End + 1
Next
Application.ScreenUpdating = True
End Sub
As you'll notice, once we have our OData helper functions in place, the more interesting VBA code deals with how to manipulate and present the data. Getting data to improve your documents is the easiest step overall.
Enjoy!