trjhtr

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.

Here is an image of 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.

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

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

Any feedback on ways to improve the performance or valid JSON strings that it can't parse would be appreciated?

Addendum

I modify the function to use Dictionaries instead of COllections to allow access to the keys.

Corrected the handling of the Javascript IsArray. It returns true when the value is vbNullString.