How to Parse JSON with VBA (MS Access/Excel)

We work with JSON a fair amount (and honestly I can’t say I care for it too much for anything outside of the JavaScript realm), and when it comes to VBA, there’s next to no support for it. Tim Hall has a great set of tools in his github repo, one in specific called VBA-JSON that tends to be a first hit when people have to go searching. I used this for a while myself, until I ran into a case that it fails on, which put me back on the drawing board.

The issue seems to be in the parsing algorithm used: some structures of valid JSON raise errors using the above code (see some examples here – and maybe watch the issue to see if there’s a fix at some point?). Furthermore, there’s a number of other “hand-made” parsers that seem to suffer the same faulty algorithm.

In any case, after numerous hours and at least a dozen different parsers being tested, I found the one that seems to work across the board. As well it should, is it’s tapping into the Microsoft JavaScript Engine to do the work. (credit to StackOverflow member Codo for the original source, as near as I can tell)

Toss the following into a standalone module. Following that is another code example for how to use this.

Module JsonParser:

Option Compare Database
Option Explicit
Public Enum JsonPropertyType
End Enum
Private ScriptEngine As Object 'ScriptControl (ref: Microsoft Script Control 1.0)
Public Sub InitScriptEngine()
    Set ScriptEngine = CreateObject("MSScriptControl.ScriptControl") 'New ScriptControl
    ScriptEngine.Language = "JScript"
    ScriptEngine.AddCode "function getProperty(jsonObj, propertyName) { return jsonObj[propertyName]; } "
    ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = new Array(); for (var i in jsonObj) { keys.push(i); } return keys; } "
End Sub
Public Function DecodeJsonString(ByVal JSonString As String)
    Set DecodeJsonString = ScriptEngine.Eval("(" + JSonString + ")")
End Function
Public Function GetProperty(ByVal JsonObject As Object, ByVal PropertyName As String) 'As Variant
    GetProperty = ScriptEngine.Run("getProperty", JsonObject, PropertyName)
End Function
Public Function GetObjectProperty(ByVal JsonObject As Object, ByVal PropertyName As String) 'As Object
    Set GetObjectProperty = ScriptEngine.Run("getProperty", JsonObject, PropertyName)
End Function
Public Function GetPropertyType(ByVal JsonObject As Object, ByVal PropertyName As String) As JsonPropertyType
    On Error Resume Next
    Dim o As Object
    Set o = GetObjectProperty(JsonObject, PropertyName)
    If Err.Number Then
        GetPropertyType = jptValue
        On Error GoTo 0
        GetPropertyType = jptObject
    End If
End Function
Public Function GetKeys(ByVal JsonObject As Object) As String()
    Dim Length As Integer
    Dim KeysArray() As String
    Dim KeysObject As Object
    Dim Index As Integer
    Dim key As Variant
    Set KeysObject = ScriptEngine.Run("getKeys", JsonObject)
    Length = GetProperty(KeysObject, "length")
    ReDim KeysArray(Length - 1)
    Index = 0
    For Each key In KeysObject
        KeysArray(Index) = key
        Index = Index + 1
    GetKeys = KeysArray
End Function

To use it, do something like this:

Option Explicit
Public Function ReadJSON()
    Dim root As Object
    Dim content As String
    Dim rootKeys() As String
    Dim keys() As String
    Dim i As Integer
    Dim obj As Object
    Dim prop As Variant
    content = FileSys.FileToString(CurrentProject.Path & "\example0.json")
    content = Replace(content, vbCrLf, "")
    content = Replace(content, vbTab, "")
    Set root = JsonParser.DecodeJsonString(content)
    rootKeys = JsonParser.GetKeys(root)
    For i = 0 To UBound(rootKeys)
        Debug.Print rootKeys(i)
        If JsonParser.GetPropertyType(root, rootKeys(i)) = jptValue Then
            prop = JsonParser.GetProperty(root, rootKeys(i))
            Debug.Print Nz(prop, "[null]")
            Set obj = JsonParser.GetObjectProperty(root, rootKeys(i))
            RecurseProps obj, 2
        End If
    Next i
End Function

Private Function RecurseProps(obj As Object, Optional Indent As Integer = 0) As Object
    Dim nextObject As Object
    Dim propValue As Variant
    Dim keys() As String
    Dim i As Integer
    keys = JsonParser.GetKeys(obj)
    For i = 0 To UBound(keys)
        If JsonParser.GetPropertyType(obj, keys(i)) = jptValue Then
            propValue = JsonParser.GetProperty(obj, keys(i))
            Debug.Print Space(Indent) & keys(i) & ": " & Nz(propValue, "[null]")
            Set nextObject = JsonParser.GetObjectProperty(obj, keys(i))
            Debug.Print Space(Indent) & keys(i)
            RecurseProps nextObject, Indent + 2
        End If
    Next i
End Function

Admittedly, it could be easier to use. This effectively parses the values (for any valid JSON – I tested loads of it and gave a presentation at the annual PAUG conference last year without an egg on my face), but working with the values when you’re done is a bit of a headache. Essentially loop through the keys and determine if it’s a Property or Object, and recurse as required. If only JSON has an equivalent query language like XPath for XML!

One important thing to bear in mind is that this method does make use of JavaScript’s Eval() function. That function basically says “take any string and execute it as if it were JavaScript”, which has some significant security implications. Thus, we ought to ensure we’re working with a trusted source if we’re going to be using it (but this holds true for just about any external source, I think).

In any case – while Tim Hall’s interface is a bit more friendly to use and works in most cases, this one works in all cases.

If you’re interested in some more information on how to consume web services with VBA, check out the Web Work with VBA blog post. Have fun!

(NOTE: NZ() in Excel – the NZ() function is an Access function and not available in excel. If you’re trying to use this code in excel, you’ll need another way to handle nulls. NZ() takes any value and tests it for null, converting it to a number or string if the value is null – google can help)

Share on:

Recent articles