Recursive VBA JSON Parser for Excel

• Download source (v1.1) - 47.2 KB
• Download source (v1.0) - 43.4 KB

Introduction

This is a VBA class that can parse recursive JSON data.

Background

I needed to parse JSON data that was highly recursive (Arrays in objects buried in other objects). I didn't find anything suitable already in VBA so I put something together. I thought the result was worthy of sharing.

The class can be used to load JSON data directly from the web, although the sample code loads data to a file first to allow the JSON data to be compared with the parsed data. Parsed data is returned in arrays.

Using the Code

The parser is passed the JSON text in a string through the "loadstring" method. The text is then parsed into two arrays; one containing keys, the other containing values. A ">" character is used to indicate a level of key recursion. Each time a "{" or "[" control character is detected, the level is increased. Each time a "}" or "]" control character is detected, the level decreases.

The following JSON string:

{
    "Category": "Famous Pets",
    "Pet": {
        "Size": "Little",
        "Type": "Lamb",
        "Coat": {
            "Fur": "Fleece",
            "Color": "White",
            "Texture": "Like snow"
        }
    }
}

Is then parsed into a set of keys and values:

Once the JSON text has been parsed, a number of properties are used to read the parsed text. The number of key/value pairs is read using the "NumElements" property (in the example above, NumElements = 6). The indexed "Key" and "Value" properties then hold the parsed information. Keys and values are returned from the class as strings. Null values are returned as zero length strings.

The class also contains an "err" (status) property to give some indication as to what's going on inside the class. Err is a long value:

1 = JSON string has been successfully parsed
-1 = JSON string has not been loaded, no results are available
-2 = JSON string cannot be correctly parsed (JSON text not fully or incorrectly formed)

The following code then makes up the class:

Global variables allow the parsed JSON text to be persistent and read out through properties of the class:

Private strKey As Variant
Private strVal As Variant
Private intHMax As Integer
Private lngStatus As Long  

The following function initializes the class. A status variable is set to indicate that no JSON data has been parsed, this variable is then updated during the parsing of the text.

Private Sub Class_Initialize()
    lngStatus = -1
End Sub  

The "NumElements" property allows the user to determine the number of key/value pairs that have been extracted from the JSON text:

Public Property Get NumElements() As Integer
    NumElements = intHMax
End Property

The keys and values are then made available as array elements. VBA uses a variant type to pass an array value. Array elements that are 'out of bounds' are returned as a zero length string:

Public Property Get Key(Index As Integer) As Variant
    If Index > UBound(strKey) Or Index < LBound(strKey) Then
        Key = ""
    Else
        Key = strKey(Index)
    End If
End Property

Public Property Get Value(Index As Integer) As Variant
    If Index > UBound(strVal) Or Index < LBound(strVal) Then
        Value = ""
    Else
        Value = strVal(Index)
    End If
End Property

The heart of the class is the code that parses the JSON string. The code looks for the next available control character in the JSON text, captures the text before the control character and shortens the initial string to the remaining JSON text. The captured text is then used to populate the keys and values. The process repeats until the initial string has been reduced to nothing. The parser also allows verbose debug data sent to the immediate window by setting: blDebug = True.

Public Sub LoadString(JSONText As String)
'Load the JSON text into an array

    Const cLongMax = (2 ^ 31) - 1 'Maximum Value for Long type
    
    Dim lngIndex As Long
    Dim lngContLoc As Long
    Dim lngLoc As Long
    Dim lngDelimitOffset As Long
    Dim lngASize As Long
    
    Dim intNoOfChecks As Integer 'Number of different control characters in JSON
    Dim intCheck As Integer
    Dim intCtrlChr As Integer
    Dim intObJLvl As Integer
    Dim intAryElement As Integer
    Dim intLvl As Integer
    
    Dim strID As String
    Dim strChr As String
    Dim strKeyValue As String
    Dim strValue As String
    Dim strPChar As String
    Dim strFoundVal As String
    Dim strTempString As String
    Dim strAKey() As String
    Dim strAVal() As String
    Dim strALvlKey(100) As String
    
    Dim blArray As Boolean 'Flag to indicate that an array has been found
    Dim blStringArray As Boolean 'Flag to indicate that the element in the array is a string (added v1.1)
    Dim BlArrayEnd As Boolean 'Flag to indicate that the end of an array is found (added v1.1)
    Dim blValue As Boolean 'Falg to indicate that a value has been found
    Dim blKeyAndValue As Boolean 'Found a key and value pair
    Dim blDebug As Boolean
    
    'Set the flag to true if you want to see debug information
    'during the loading process
    blDebug = True
    
    On Error GoTo ErrHandler:
    
    lngASize = 10
    ReDim strAKey(lngASize)
    ReDim strAVal(lngASize)
    
    'intArrayElement = 1 'initialize value
    'initialize values
    blArray = False
    BlArrayEnd = False '(added v1.1)
    blStringArray = False '(added v1.1)
    
    'Generate a string of control characters
    'String is {[:,]}"
    strID = ""
    strID = strID & Chr(123) 'The '{' character
    strID = strID & Chr(91)  'The '[' character
    strID = strID & Chr(58)  'The ':' character
    strID = strID & Chr(44)  'The ',' character
    strID = strID & Chr(93)  'The ']' character
    strID = strID & Chr(125) 'The '}' character
    strID = strID & Chr(34)  'The '"' character
    
    intNoOfChecks = Len(strID)
    intObJLvl = 0
    lngIndex = 1 'First element in the array will be strKey(1) and strVal(1)
    
    'As we process the JSON string it becomes shorter and shorter, until
    'its all been processed
    Do While Len(JSONText) > 0

        'Set to maximum value as default
        lngContLoc = cLongMax
        
        'Find Next control character:
        'Scan the text for the closest control character
        'to the beginning of the remaining JSON text
        For intCheck = 1 To intNoOfChecks
        
       
            strChr = Mid(strID, intCheck, 1)
            lngLoc = InStr(1, JSONText, strChr, vbBinaryCompare)
        
            If (lngLoc > 0) And (lngLoc < lngContLoc) Then
                lngContLoc = lngLoc
                intCtrlChr = intCheck
                strPChar = strChr
            End If
        
        Next intCheck
        
        'When the above for next loop ends we will have found the closest control character
        'stored in intCtrlChr - an index (1 to 8) to the found character in strChr
        'stored in lngContLoc - position of the next control character
        'stored in strPChar - the closest next control character
        
        If blDebug = True Then
            Debug.Print "Parse Character: " & strPChar
        End If
        
        'A control character has been found, figure out what to do by the found character
        If lngContLoc < cLongMax Then
         'Capture the information before the control character
         strValue = Mid(JSONText, 1, lngContLoc - 1)
         'Capture everything after the control character (the remaining JSON string)
         JSONText = Mid(JSONText, lngContLoc + 1, Len(JSONText))
        Else
            'We found the end of the JSON string
            Exit Do
        End If
        
        'Found a number or boolean value or key (the comma)
        'Updated in v1.1 to handle number types in array (process value as string or number; not both)
        If (intCtrlChr = 4) Then
          If ((blValue = True) Or (blArray = True)) And (blStringArray = False) Then
            'Found a value, and we already have key
            strFoundVal = fnStringToVal(strValue)
            blKeyAndValue = True 'Set the "Key and value found" flag
          End If
          'Finding a comma resets the string found in the array
           blStringArray = False
        End If
        
        'Start of object (The "{" character)
        If intCtrlChr = 1 Then
            intObJLvl = intObJLvl + 1
            blArray = False 'An object, not an array
            blValue = False 'Need to find a key first
            If blDebug = True Then
                Debug.Print "Start of Object, Moved up to level" & intObJLvl
            End If
        End If
        
        'End of of object (The "}" character)
        If intCtrlChr = 6 Then
            'Updated in Revision 1.1
            'Numbers preceded by the "}" character
            If blValue = True Then
                'Get the found value and set a flag
                strFoundVal = fnStringToVal(strValue)
                blKeyAndValue = True 'Set the "Key and value found" flag
                'Add back a "}" character to the string so that the level can be decremented properly
                JSONText = "}" & JSONText
            Else
                'No value was found, the "}" character indicates the end of this level
                intObJLvl = intObJLvl - 1
                blValue = False 'Need to find a key first
            End If
            If blDebug = True Then
                Debug.Print "End of Object, Moved down to level" & intObJLvl
            End If
        End If
        
        'Start of array (The "[" character)
        If intCtrlChr = 2 Then
            'intObJLvl = intObJLvl + 1
            'strALvlKey(intObJLvl) = intArrayElement
            blArray = True
            blValue = True 'Next thing should be a value
            intAryElement = 1
            If blDebug = True Then
                Debug.Print "Start of Array, Moved up to level" & intObJLvl
            End If
        End If
        
        'End of of array (The "]" character)
        If intCtrlChr = 5 Then
            'Updated v1.1 parse last numeric or boolean value of an array
            If (blArray = True) And (blStringArray = False) Then
                'Get the found value and set a flag
                strFoundVal = fnStringToVal(strValue)
                blKeyAndValue = True 'Set the "Key and value found" flag
            End If
                BlArrayEnd = True 'Mark that the end of the array is found
                blArray = False
                blValue = False 'Need to find a key first
            If blDebug = True Then
                Debug.Print "End of Array, Moved down to level" & intObJLvl
            End If
        End If
        
        'Object Value start is found (The ":" character)
        If intCtrlChr = 3 Then
            blValue = True
            BlArrayEnd = False 'Added v1.1, start of an object value is not the end of an array
            If blDebug = True Then
                Debug.Print "ready to get value"
            End If
        End If
        
        'Start of a string (the quote " character)
        'Can be a key or value
        If intCtrlChr = 7 Then
        
            'The start of the key or value has been found
            'The next quote will end the key or value
            '(unless the quote has an escape character in front of it "\")
            
            lngDelimitOffset = 1
          
            Do
                'Look for the next quote character
                lngLoc = InStr(lngDelimitOffset, JSONText, Chr(34), vbBinaryCompare)
                
                'If the string is zero length "" then exit the loop
                If lngLoc = 1 Then
                    Exit Do
                End If
            
                'Check to see if there is a delimter just before the quote
                'if there is then quote is part of the string and not the end of
                'the string.
                If Mid(JSONText, lngLoc - 1, 1) = Chr(92) Then
                    ' The quote character has an escape character in front of it
                    'so this quote doesn't count.  Remove the escape character.
                    JSONText = Mid(JSONText, 1, lngLoc - 2) & Mid(JSONText, lngLoc, Len(JSONText))
                    'and move the start of the check past the delimited quote
                    lngDelimitOffset = lngLoc
                    
                    'If we have a boogered JSON string where there is no valid closing quotes
                    'the above "if" will cause an error (the MID statement will attempt to check
                    'the string starting at a position of -1) and the code will jump to the error
                    'handling section.  If this error didn't occur the do..loop would get stuck.
    
                Else
                    Exit Do
                End If
            Loop
            
            'We now have a string, find any other delimiters
            '(any delimited " characters have already been fixed)
            strTempString = fnStringFix(Mid(JSONText, 1, lngLoc - 1))
            
            If (blValue = True) Or (blArray = True) Then
                'The key has been previously found and this is the value for the key
                strFoundVal = strTempString
                blKeyAndValue = True 'Set the "Key and value found" flag
                If blArray = True Then
                    blStringArray = True 'Added v1.1, mark that the value is a string
                End If
            Else
                If lngLoc > 0 Then
                    'We've found a key
                    strALvlKey(intObJLvl) = strTempString
                    If blDebug = True Then
                        Debug.Print "Found Key:" & strALvlKey(intObJLvl) & _
                                    " for Level: " & intObJLvl
                    End If
                End If
            End If
            JSONText = Mid(JSONText, lngLoc + 1, Len(JSONText))
        End If
        
        
        'Found a key and value, move it to the array
        If blKeyAndValue = True Then
        
            If lngIndex > lngASize Then
                lngASize = lngASize + 100
                ReDim Preserve strAKey(lngASize)
                ReDim Preserve strAVal(lngASize)
            End If
        
            strAKey(lngIndex) = ""
            For intLvl = 1 To intObJLvl
                strAKey(lngIndex) = strAKey(lngIndex) & ">" & strALvlKey(intLvl)
            Next intLvl
            
            'Updated v1.1 - save last element of an array
            If (blArray = True) Or (BlArrayEnd = True) Then
                'add the array element to the key
                strAKey(lngIndex) = strAKey(lngIndex) & ">" & Trim(str(intAryElement))
                'increment the array element
                intAryElement = intAryElement + 1
                'Reset end of array flag (set again when array end is found)
                BlArrayEnd = False
            End If
            
            strAVal(lngIndex) = strFoundVal
            If blDebug = True Then
                Debug.Print "Added Key:" & strAKey(lngIndex) & _
                " Value: " & strAVal(lngIndex) & " index: " & lngIndex
            End If
            lngIndex = lngIndex + 1 'Increment the array
            blKeyAndValue = False 'Reset the "found" flag
            blValue = False 'Reset the "Value Found" flag
        End If
    DoEvents
    Loop
    
    'Number of items found
    intHMax = lngIndex - 1
    strKey = strAKey
    strVal = strAVal
    lngStatus = 1 'JSON sucessfully parsed
Exit Sub
ErrHandler:
    
    'Error handling code
    lngStatus = -2 'JSON Parse error
    'Uncomment the next line to figure out the cause of the issue
    'Debug.Print VBA.err.Number
    'Debug.Print VBA.err.Description
    'Resume
    
End Sub

The values are stripped of any non-text formatting. Values should be numbers (integer, floating point, or "null"). Values read as 'null' are further converted into a zero length string.

Private Function fnStringToVal(strInStr As String) As String
'Converts a string that contains formatting information into a string that only
'contains a value.  Values can be text, integer, or floating point values.
'null is passed back as a zero length string: "".

    Dim intStrPos As Integer
    Dim strTemp As String
    Dim intChar As Integer
    
    'default value
    strTemp = ""
    
    'Make sure that the string does not have a zero length
    strInStr = " " & strInStr
    
    'Loop through each character in the string and remove anything
    'that is not alphanumeric.
    For intStrPos = 1 To Len(strInStr)
        intChar = Asc(Mid(strInStr, intStrPos, 1))
        
        If ((intChar >= Asc("a")) And (intChar <= Asc("z"))) Or _
           ((intChar >= Asc("A")) And (intChar <= Asc("Z"))) Or _
           ((intChar >= Asc("0")) And (intChar <= Asc("9"))) Or _
           (intChar = Asc(".")) Or (intChar = Asc("+")) Or (intChar = Asc("-")) Then
           
           strTemp = strTemp & Chr(intChar)
        End If
    
    Next intStrPos
    
    'Values that are listed as 'null' are converted to a zero length string
    If InStr(1, "null", strTemp, vbTextCompare) > 0 Then
        strTemp = ""
    End If
    
    fnStringToVal = strTemp

End Function

Finally, JSON supports a number of escape codes. This function looks through the passed string and performs the requested escape sequence. While VBA strings support Unicode characters, other parts of Microsoft Excel are more random. Parsed text that is sent to cells or message boxes may not behave as expected and may require further processing.

Private Function fnStringFix(strInput As String) As String
'This function goes through a JSON string and corrects delimited characters

Dim blParseComplete As Boolean
Dim lngStartPos As Long
Dim lngCurrentPos As Long

blParseComplete = False
lngStartPos = 1

Do While blParseComplete = False
    blParseComplete = True 'If we don't find any escape sequences then allo the loop to end
    
    'Escaped sequence: replace \\ with \
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\\", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & "\" & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \/ with /
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\/", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & "/" & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \b with a backspace
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\b", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & Chr(8) & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If
    
    'Escaped sequence: replace \f with a formfeed
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\f", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & Chr(12) & _
                     Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \n with a newline
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\n", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & Chr(10) & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \r with a carriage return
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\r", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & Chr(13) & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \t with a horizontal tab
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\t", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & Chr(9) & _
                    Mid(strInput, lngCurrentPos + 2, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

    'Escaped sequence: replace \uXXXX with a unicode character
    'look for the specific escape sequence
    lngCurrentPos = InStr(lngStartPos, strInput, "\u", vbTextCompare) 
    If lngCurrentPos > 0 Then
        strInput = Mid(strInput, 1, lngCurrentPos - 1) & _
                    ChrW$(CLng("&h" & Mid(strInput, lngCurrentPos + 2, 4))) & _
                    Mid(strInput, lngCurrentPos + 6, Len(strInput))
        blParseComplete = False 'set the status to check for another escape
    End If

Loop

fnStringFix = strInput
End Function

Points of Interest

Keys for array elements are numbered when they generate a value. In the example below, the keys indicate the position of the value within the array.

{
    "prices": {
        "USD": [
            [1,"1.25"],
            [25,"1.17"],
            [50,"0.95"]
            ],
        "EUR": [
            [1,"0.98"],
            [25,"0.92"],
            [50,"0.74"]
            ]
    }
}

The JSON above is parsed into the following keys and values:

The downloadable demo is setup to load one of three URLs to a text file using the “URL to File” buttons. I’ve added some JSON sources as reference. The “Parse File” button then loads these text files and parses the JSON data into Sheet2 of the spreadsheet.

History

• Rev 1.0 - Initial release
• Rev 1.1 - Updated to correctly parse numeric values that are followed by the ']' or '}' control characters. These values are ignored in the initial release.