Function to return JSON-like objects using VBA collections and arrays

Question

My goal is to create a compact function that can create a JSON Like object from JSON string. I want a function with a small footprint that I or anyone who wants to use it, can simply paste into a module and use. At 61 lines of code, I am happy with its size and portability. Any feedback on ways to improve the performance or valid JSON strings that it can't parse would be appreciated.

Here is an image of a JSON object created from string data using a ScriptControl. Although the Locals Window displays the properties and values correctly, the object itself is extremely difficult to work with.

objJSON

This image shows an object created using getJSONCollection. Because it is made of VBA collections and arrays, it is very easy to work with.

colJSON

Option Explicit
Private Function getJSONCollection(ByVal Value As Variant, Optional ScriptEngine As Object) As Variant
 Const DELIMITER As String = "||"
 Dim col As Collection, JSON As Object, KeyNames() As String, results() As Variant
 Dim j As Long, k As Long, length As Long
 Set col = New Collection
 If ScriptEngine Is Nothing Then
 Set ScriptEngine = CreateObject("MSScriptControl.ScriptControl")
 ScriptEngine.Language = "JScript"
 ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = ''; for (var n in jsonObj) { keys += n + '" & DELIMITER & "' ; } return keys.substring(0, keys.length-" & Len(DELIMITER) & "); } "
 ScriptEngine.AddCode "function isArray(jsonObj) { return ( Object.prototype.toString.call( jsonObj ) === '[object Array]' );} "
 End If
 If TypeName(Value) = "String" Then
 Set JSON = ScriptEngine.Eval("(" + Value + ")")
 ElseIf TypeName(Value) = "JScriptTypeInfo" Then
 Set JSON = Value
 End If
 KeyNames = Split(ScriptEngine.Run("getKeys", JSON), DELIMITER)
 If ScriptEngine.Run("isArray", JSON) Then
 length = CallByName(JSON, "length", VbGet)
 ReDim results(length)
 For j = 0 To length - 1
 Value = CallByName(JSON, j, VbGet)
 For k = 0 To UBound(KeyNames)
 If InStr(Value, "[object Object]") Then
 Set results(j) = getJSONCollection(CallByName(JSON, KeyNames(k), VbGet), ScriptEngine)
 Else
 If Not IsNull(Value) Then results(j) = Value
 End If
 Next
 Next
 col.Add results, "getArray"
 Else
 For j = 0 To UBound(KeyNames)
 On Error Resume Next
 Set Value = CallByName(JSON, KeyNames(j), VbGet)
 If Err.Number <> 0 Then
 Err.Clear
 Value = CallByName(JSON, KeyNames(j), VbGet)
 End If
 On Error GoTo 0
 If TypeName(Value) = "Collection" Then
 'Do Nothing
 ElseIf InStr(Value, "[object Object]") Then
 Set Value = getJSONCollection(CallByName(JSON, KeyNames(j), VbGet), ScriptEngine)
 ElseIf TypeName(Value) = "JScriptTypeInfo" Then
 'Array Handler
 Set Value = getJSONCollection(Value, ScriptEngine)
 End If
 col.Add Value, KeyNames(j)
 Next
 End If
 Set getJSONCollection = col
End Function
Sub TestJSONCollection()
 Dim JSONExamples As Object, ExampleDoc As Object
 Set ExampleDoc = getDocument("http://json.org/example.html")
 Set JSONExamples = ExampleDoc.getElementsByTagName("Pre")
 Example1 JSONExamples(0).innerText
End Sub
Sub Example1(JSONString As String)
 Dim objJSON As Object, colJSON As Collection
 Set objJSON = DecodeJSON(JSONString)
 Set colJSON = getJSONCollection(JSONString)
 Debug.Print "Example1: JSON String"
 Debug.Print JSONString
 Debug.Print String(20, "*") & "Example1: Output" & String(20, "*")
 Debug.Print "colJSON!glossary!title:", colJSON!glossary!Title
 Debug.Print "colJSON!glossary!GlossDiv!title:", colJSON!glossary!GlossDiv!Title
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!ID:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!ID
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!SortAs:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!SortAs
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossTerm:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossTerm
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!Acronym:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!Acronym
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!Abbrev:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!Abbrev
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!para:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!para
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso(0):", colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso!getArray()(0)
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso(1):", colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso(1)(1), "Alt Syntax"
 Debug.Print "colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossSee:", colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossSee
End Sub
Function DecodeJSON(JSONString As String) As Object
 With CreateObject("MSScriptControl.ScriptControl")
 .Language = "JScript"
 Set DecodeJSON = .Eval("(" + JSONString + ")")
 End With
End Function
Function getDocument(URL As String) As Object
 Dim doc As Object
 With CreateObject("MSXML2.XMLHTTP")
 .Open "GET", URL, False
 .send
 If .readyState = 4 And .Status = 200 Then
 Set doc = New MSHTML.HTMLDocument
 doc.body.innerHTML = .responseText
 Set getDocument = doc
 Else
 MsgBox "URL: " & vbCrLf & "Ready state: " & .readyState & vbCrLf & "HTTP request status: " & .Status, vbInformation, "URL Not Responding"
 End If
 End With
End Function

This creates a JSON Collection object from the first JSON example from json.org/example.html and outputs both the values and the method used to access the values to the Immediate Window.

Example1: JSON String

{
 "glossary": {
 "title": "example glossary",
 "GlossDiv": {
 "title": "S",
 "GlossList": {
 "GlossEntry": {
 "ID": "SGML",
 "SortAs": "SGML",
 "GlossTerm": "Standard Generalized Markup Language",
 "Acronym": "SGML",
 "Abbrev": "ISO 8879:1986",
 "GlossDef": {
 "para": "A meta-markup language, used to create markup languages such as DocBook.",
 "GlossSeeAlso": ["GML", "XML"]
 },
 "GlossSee": "markup"
 }
 }
 }
 }
}
********************Example1: Output********************
colJSON!glossary!title: example glossary
colJSON!glossary!GlossDiv!title: S
colJSON!glossary!GlossDiv!GlossList!GlossEntry!ID: SGML
colJSON!glossary!GlossDiv!GlossList!GlossEntry!SortAs: SGML
colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossTerm: Standard Generalized Markup Language
colJSON!glossary!GlossDiv!GlossList!GlossEntry!Acronym: SGML
colJSON!glossary!GlossDiv!GlossList!GlossEntry!Abbrev: ISO 8879:1986
colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!para: A meta-markup language, used to create markup languages such as DocBook.
colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso(0): GML
colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossDef!GlossSeeAlso(1): XML Alt Syntax
colJSON!glossary!GlossDiv!GlossList!GlossEntry!GlossSee: markup

getJSONCollection:Function

Function getJSONCollection(ByVal Value As Variant, Optional ScriptEngine As Object) As Variant
 Const DELIMITER As String = "||"
 Dim col As Object, JSON As Object, KeyNames() As String, results() As Variant
 Dim j As Long, k As Long, length As Long
 Set col = CreateObject("Scripting.Dictionary")
 If ScriptEngine Is Nothing Then
 Set ScriptEngine = CreateObject("MSScriptControl.ScriptControl")
 ScriptEngine.Language = "JScript"
 ScriptEngine.AddCode "function getKeys(jsonObj) { var keys = ''; for (var n in jsonObj) { keys += n + '" & DELIMITER & "' ; } return keys.substring(0, keys.length-" & Len(DELIMITER) & "); } "
 ScriptEngine.AddCode "function isArray(jsonObj) { return ( Object.prototype.toString.call( jsonObj ) === '[object Array]' );} "
 End If
 If TypeName(Value) = "String" Then
 Set JSON = ScriptEngine.Eval("(" + Value + ")")
 ElseIf TypeName(Value) = "JScriptTypeInfo" Then
 Set JSON = Value
 End If
 KeyNames = Split(ScriptEngine.Run("getKeys", JSON), DELIMITER)
 If Len(Value) = 0 Then
 'Do Nothing
 ElseIf ScriptEngine.Run("isArray", JSON) Then
 length = CallByName(JSON, "length", VbGet)
 ReDim results(length - 1)
 For j = 0 To length - 1
 Value = CallByName(JSON, j, VbGet)
 For k = 0 To UBound(KeyNames)
 If InStr(Value, "[object Object]") Then
 Set results(j) = getJSONCollection(CallByName(JSON, KeyNames(k), VbGet), ScriptEngine)
 Else
 If Not IsNull(Value) Then results(j) = Value
 End If
 Next
 Next
 col.Add "getArray", results
 Else
 For j = 0 To UBound(KeyNames)
 On Error Resume Next
 Set Value = CallByName(JSON, KeyNames(j), VbGet)
 If Err.Number <> 0 Then
 Err.Clear
 Value = CallByName(JSON, KeyNames(j), VbGet)
 End If
 On Error GoTo 0
 'Extract Array from Dictionary
 If TypeName(Value) = "Dictionary" Then
 If Value.Exists("getArray") Then Value = Value("getArray")
 ElseIf TypeName(Value) = "Collection" Then
 'Do Nothing
 ElseIf InStr(Value, "[object Object]") Then
 Set Value = getJSONCollection(CallByName(JSON, KeyNames(j), VbGet), ScriptEngine)
 ElseIf TypeName(Value) = "JScriptTypeInfo" Then
 'Array Handler
 Set Value = getJSONCollection(Value, ScriptEngine)
 End If
 col.Add KeyNames(j), Value
 Next
 End If
 Set getJSONCollection = col
End Function

• Raystafarian: Am I reading this right - it's heavily recursive?
• TinMan: Yes, The recursion is necessary handle nested JSON objects. I actually wrote this after I started a review on your question Retrieve data from eBird API and create multi-level hierarchy of locations.
• Stephen Laurence: It works very well on selecting all the child nodes ... however I gave it a query with 50 rows and it populated all 50 records in the collection with the same values from one row.. so I had 50 rows but all had the same record details
• TinMan: @StephenLaurence Thanks. I'll check it out.
• TinMan: @TravisBemrose I don't remember. I think that the MSScriptControl.ScriptControl is no longer supported.