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:
Key(1) = ">Category" | Value(1) = "Famous Pets" |
Key(2) = ">Pet>Size" | Value(2) = "Little" |
Key(3) = ">Pet>Type" | Value(3) = "Lamb" |
Key(4) = ">Pet>Coat>Fur" | Value(4) = "Fleece" |
Key(5) = ">Pet>Coat>Color" | Value(5) = "White" |
Key(6) = ">Pet>Coat>Texture" | Value(6) = "Like snow" |
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 string
s. Null
values are returned as zero length string
s.
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)
Const cLongMax = (2 ^ 31) - 1
Dim lngIndex As Long
Dim lngContLoc As Long
Dim lngLoc As Long
Dim lngDelimitOffset As Long
Dim lngASize As Long
Dim intNoOfChecks As Integer
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
Dim blStringArray As Boolean
Dim BlArrayEnd As Boolean
Dim blValue As Boolean
Dim blKeyAndValue As Boolean
Dim blDebug As Boolean
blDebug = True
On Error GoTo ErrHandler:
lngASize = 10
ReDim strAKey(lngASize)
ReDim strAVal(lngASize)
blArray = False
BlArrayEnd = False
blStringArray = False
strID = ""
strID = strID & Chr(123)
strID = strID & Chr(91)
strID = strID & Chr(58)
strID = strID & Chr(44)
strID = strID & Chr(93)
strID = strID & Chr(125)
strID = strID & Chr(34)
intNoOfChecks = Len(strID)
intObJLvl = 0
lngIndex = 1
Do While Len(JSONText) > 0
lngContLoc = cLongMax
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
If blDebug = True Then
Debug.Print "Parse Character: " & strPChar
End If
If lngContLoc < cLongMax Then
strValue = Mid(JSONText, 1, lngContLoc - 1)
JSONText = Mid(JSONText, lngContLoc + 1, Len(JSONText))
Else
Exit Do
End If
If (intCtrlChr = 4) Then
If ((blValue = True) Or (blArray = True)) And (blStringArray = False) Then
strFoundVal = fnStringToVal(strValue)
blKeyAndValue = True
End If
blStringArray = False
End If
If intCtrlChr = 1 Then
intObJLvl = intObJLvl + 1
blArray = False
blValue = False
If blDebug = True Then
Debug.Print "Start of Object, Moved up to level" & intObJLvl
End If
End If
If intCtrlChr = 6 Then
If blValue = True Then
strFoundVal = fnStringToVal(strValue)
blKeyAndValue = True
JSONText = "}" & JSONText
Else
intObJLvl = intObJLvl - 1
blValue = False
End If
If blDebug = True Then
Debug.Print "End of Object, Moved down to level" & intObJLvl
End If
End If
If intCtrlChr = 2 Then
blArray = True
blValue = True
intAryElement = 1
If blDebug = True Then
Debug.Print "Start of Array, Moved up to level" & intObJLvl
End If
End If
If intCtrlChr = 5 Then
If (blArray = True) And (blStringArray = False) Then
strFoundVal = fnStringToVal(strValue)
blKeyAndValue = True
End If
BlArrayEnd = True
blArray = False
blValue = False
If blDebug = True Then
Debug.Print "End of Array, Moved down to level" & intObJLvl
End If
End If
If intCtrlChr = 3 Then
blValue = True
BlArrayEnd = False
If blDebug = True Then
Debug.Print "ready to get value"
End If
End If
If intCtrlChr = 7 Then
lngDelimitOffset = 1
Do
lngLoc = InStr(lngDelimitOffset, JSONText, Chr(34), vbBinaryCompare)
If lngLoc = 1 Then
Exit Do
End If
If Mid(JSONText, lngLoc - 1, 1) = Chr(92) Then
JSONText = Mid(JSONText, 1, lngLoc - 2) & Mid(JSONText, lngLoc, Len(JSONText))
lngDelimitOffset = lngLoc
Else
Exit Do
End If
Loop
strTempString = fnStringFix(Mid(JSONText, 1, lngLoc - 1))
If (blValue = True) Or (blArray = True) Then
strFoundVal = strTempString
blKeyAndValue = True
If blArray = True Then
blStringArray = True
End If
Else
If lngLoc > 0 Then
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
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
If (blArray = True) Or (BlArrayEnd = True) Then
strAKey(lngIndex) = strAKey(lngIndex) & ">" & Trim(str(intAryElement))
intAryElement = intAryElement + 1
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
blKeyAndValue = False
blValue = False
End If
DoEvents
Loop
intHMax = lngIndex - 1
strKey = strAKey
strVal = strAVal
lngStatus = 1
Exit Sub
ErrHandler:
lngStatus = -2
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
Dim intStrPos As Integer
Dim strTemp As String
Dim intChar As Integer
strTemp = ""
strInStr = " " & strInStr
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
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 string
s 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
Dim blParseComplete As Boolean
Dim lngStartPos As Long
Dim lngCurrentPos As Long
blParseComplete = False
lngStartPos = 1
Do While blParseComplete = False
blParseComplete = True
lngCurrentPos = InStr(lngStartPos, strInput, "\\", vbTextCompare)
If lngCurrentPos > 0 Then
strInput = Mid(strInput, 1, lngCurrentPos - 1) & "\" & _
Mid(strInput, lngCurrentPos + 2, Len(strInput))
blParseComplete = False
End If
lngCurrentPos = InStr(lngStartPos, strInput, "\/", vbTextCompare)
If lngCurrentPos > 0 Then
strInput = Mid(strInput, 1, lngCurrentPos - 1) & "/" & _
Mid(strInput, lngCurrentPos + 2, Len(strInput))
blParseComplete = False
End If
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
End If
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
End If
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
End If
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
End If
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
End If
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
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:
Key(1) = ">prices>USD>1" | Value(1) = "1" |
Key(2) = ">prices>USD>2" | Value(2) = "1.25" |
Key(3) = ">prices>USD>1" | Value(3) = "25" |
Key(4) = ">prices>USD>2" | Value(4) = "1.17" |
Key(5) = ">prices>USD>1" | Value(5) = "50" |
Key(6) = ">prices>USD>2" | Value(6) = "0.95" |
Key(7) = ">prices>EUR>1" | Value(7) = "1" |
Key(8) = ">prices>EUR>2" | Value(8) = "0.98" |
Key(9) = ">prices>EUR>1" | Value(9) = "25" |
Key(10) = ">prices>EUR>2" | Value(10) = "0.92" |
Key(11) = ">prices>EUR>1" | Value(11) = "50" |
Key(12) = ">prices>EUR>2" | Value(12) = "0.74" |
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.