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