4
\$\begingroup\$

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
Improve this question
\$\endgroup\$
6
  • \$\begingroup\$ Am I reading this right - it's heavily recursive? \$\endgroup\$
    – Raystafarian
    Jun 14, 2018 at 21:43
  • \$\begingroup\$ 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. \$\endgroup\$
    – TinMan
    Jun 15, 2018 at 1:04
  • \$\begingroup\$ 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 \$\endgroup\$
    – Stephen Laurence
    Jun 3, 2019 at 9:52
  • \$\begingroup\$ @StephenLaurence Thanks. I'll check it out. \$\endgroup\$
    – TinMan
    Jun 4, 2019 at 3:01
  • 1
    \$\begingroup\$ @TravisBemrose I don't remember. I think that the MSScriptControl.ScriptControl is no longer supported. \$\endgroup\$
    – TinMan
    Oct 1 at 14:50

0

Reset to default

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Browse other questions tagged or ask your own question.