VBA - Bang Syntax Part2 - JSON Parsing Revisited (again!)

Plenty of JSON parsing posts on this blog and here I return again to the subject.

I was so hopefuil when I discovered the ScriptControl and its ability to return parsed JSON, one could use the dot notation to traverse the hierarchy if it weren't for VBA amending casing, see this SO question for a complete example of this pain. The answer then was to use CallByName and that still is the answer but we can use the bang ! syntax where the dots used to be using the following code.

First, let me show you the client code to whet your appetite. Q. How does this solves the casing issue? A. Because the text to the right of the bang ! is treated as a string to be passed to the default member (which I will show you how to setup shortly).

Sub Test()

    Dim oJSONParser As JSONParser
    Set oJSONParser = New JSONParser
    
    Dim sJSON As String
    sJSON = VBA.Replace("{ 'name':'John', 'age':30, 'cars':{ 'car1':'Ford','car2':'BMW','car3':'Fiat'} }", "'", """")
    
    Dim oJSONBang As JSONBang
    Set oJSONBang = oJSONParser.DecodeJsonString(sJSON)

    Dim oCars As JSONBang
    Set oCars = oJSONBang!cars  ' drill into cars property
    
    Dim sCar2 As String
    sCar2 = oCars!car2     ' drill into car2 property
    
    '* or use chain syntax
    sCar2 = oJSONBang!cars!car2
    

    Stop

End Sub

Ok so there are two classes, JSONParser and JSONBang, the former houses the parser logic whilst the latter represents each segment.

JSONParser class

So this parser class uses the Microsoft Script Control but uses a downloaded script authored by Douglas Crockford that parses JSON to an object. Please use Douglas's script and please DO NOT USE EVAL. I have also added a ToString override helper function.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "JSONParser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'* Tools->References
' MSScriptControl      Microsoft Script Control 1.0    C:\Windows\SysWOW64\msscript.ocx
' Scripting            Microsoft Scripting Runtime     C:\Windows\SysWOW64\scrrun.dll
' MSXML2               Microsoft XML, v6.0             C:\Windows\SysWOW64\msxml6.dll

Private Function SC() As ScriptControl
    Static soSC As ScriptControl
    If soSC Is Nothing Then

        Set soSC = New ScriptControl
        soSC.Language = "JScript"
        
        '* https://stackoverflow.com/questions/45015/safely-turning-a-json-string-into-an-object
        soSC.AddCode GetJavaScriptLibrary("https://raw.githubusercontent.com/douglascrockford/JSON-js/master/json2.js")
        soSC.AddCode "function JSON_parse(sJson) { return JSON.parse(sJson); } "
        soSC.AddCode "function overrideToString(jsonObj) { jsonObj.toString = function() { return JSON.stringify(this); } }"

    End If
    Set SC = soSC
End Function

Private Function GetJavaScriptLibrary(ByVal sURL As String) As String

    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.send
    GetJavaScriptLibrary = xHTTPRequest.responseText

End Function

Public Function DecodeJsonString(ByVal JsonString As String) As JSONBang
    Dim oSC As ScriptControl
    Set oSC = SC

    Dim obj As Object
    Set obj = oSC.Run("JSON_parse", JsonString)

    Call oSC.Run("overrideToString", obj) '* this gives JSON rendering instead of "[object Object]"

    Set DecodeJsonString = New JSONBang
    Set DecodeJsonString.JScriptTypeInfo = obj

End Function

JSONBang class

So this JSONBang class has the Item method annotated with Attribute Item.VB_UserMemId = 0 so it becomes the default method and that way we can use bang ! because it looks for a default method with a single parameter and passes that to the right of the bang as the parameter.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "JSONBang"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private mobjJScriptTypeInfo As Object

Public Property Set JScriptTypeInfo(rhs As Object)
    If TypeName(rhs) = "JScriptTypeInfo" Then
        Set mobjJScriptTypeInfo = rhs
    Else
        Err.Raise 13
    End If
End Property

Public Property Get JScriptTypeInfo() As Object
    Set JScriptTypeInfo = mobjJScriptTypeInfo
End Property

Public Function ToString() As String
    ToString = mobjJScriptTypeInfo
End Function

Public Function Item(Key)
Attribute Item.VB_UserMemId = 0
    
    'Attribute Item.VB_UserMemID = 0
    
    If mobjJScriptTypeInfo Is Nothing Then Err.Raise vbObjectError, "#base JSON class (JScriptTypeInfo) not yet!"
    
    If IsObject(CallByName(mobjJScriptTypeInfo, Key, VbGet)) Then
    
        Dim obj As Object
        Set obj = CallByName(mobjJScriptTypeInfo, Key, VbGet)
    
        Dim oRet As JSONBang
        Set oRet = New JSONBang
        Set oRet.JScriptTypeInfo = obj
        
        Set Item = oRet
    
    Else
        Dim vVar
        vVar = CallByName(mobjJScriptTypeInfo, Key, VbGet)
        Item = vVar
    End If
    

End Function