Excel 的递归 VBA JSON 解析器
用于 VBA 类模块的 JSON 解析器，支持递归数据
引言
这是一个 VBA 类，可以解析递归的 JSON 数据。
背景
我需要解析一个高度递归的 JSON 数据（嵌套在其他对象中的数组）。我在 VBA 中找不到合适的东西，所以自己做了一个。我认为这个结果值得分享。
该类可以直接从 Web 加载 JSON 数据，尽管示例代码会将数据先加载到文件中，以便将 JSON 数据与解析后的数据进行比较。解析后的数据以数组的形式返回。
Using the Code
解析器通过 "loadstring" 方法接收一个 `string` 类型的 JSON 文本。然后文本被解析到两个数组中；一个包含键，另一个包含值。">" 字符用于表示键的递归级别。每次检测到 "{" 或 "[" 控制字符时，级别就会增加。每次检测到 "}" 或 "]" 控制字符时，级别就会降低。
以下 JSON `string`
{
"Category": "Famous Pets",
"Pet": {
"Size": "Little",
"Type": "Lamb",
"Coat": {
"Fur": "Fleece",
"Color": "White",
"Texture": "Like snow"
}
}
}
然后被解析为一组键和值
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" |
JSON 文本解析完成后，将使用若干属性来读取解析后的文本。"NumElements" 属性用于读取键/值对的数量（在上例中，NumElements = 6）。索引的 "Key" 和 "Value" 属性随后包含解析后的信息。键和值以 `string` 的形式从类中返回。`Null` 值以零长度 `string` 的形式返回。
该类还包含一个 "err"（状态）属性，以提供有关类内部发生情况的一些指示。`Err` 是一个 long 值
1 = JSON string 已成功解析
-1 = JSON string 未加载，没有可用结果
-2 = JSON string 无法正确解析（JSON 文本不完整或格式错误）
以下代码构成了该类
全局变量允许解析后的 JSON 文本保持持久，并通过类的属性读取出来
Private strKey As Variant
Private strVal As Variant
Private intHMax As Integer
Private lngStatus As Long
以下函数初始化该类。设置一个 `status` 变量以指示尚未解析任何 JSON 数据，然后在文本解析过程中更新此变量。
Private Sub Class_Initialize()
lngStatus = -1
End Sub
"NumElements" 属性允许用户确定从 JSON 文本中提取的键/值对的数量
Public Property Get NumElements() As Integer
NumElements = intHMax
End Property
键和值随后作为数组元素提供。VBA 使用 variant 类型来传递数组值。超出界限的数组元素将以零长度 `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
该类的核心是解析 JSON `string` 的代码。代码会查找 JSON 文本中下一个可用的控制字符，捕获控制字符之前的文本，并将原始 `string` 缩短为剩余的 JSON 文本。然后使用捕获的文本填充键和值。此过程将重复进行，直到原始 `string` 被完全解析。通过设置 `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
值会剥离任何非文本格式。值应为数字（整数、浮点数或 "null"）。读取为 'null' 的值会被进一步转换为零长度 `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
最后，JSON 支持多种转义码。此函数会检查传入的 `string` 并执行请求的转义序列。虽然 VBA `string` 支持 Unicode 字符，但 Microsoft Excel 的其他部分则更加不确定。发送到单元格或消息框的解析文本可能行为不符合预期，可能需要进一步处理。
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
关注点
数组元素的键在生成值时会被编号。在下面的示例中，键指示了值在数组中的位置。
{
"prices": {
"USD": [
[1,"1.25"],
[25,"1.17"],
[50,"0.95"]
],
"EUR": [
[1,"0.98"],
[25,"0.92"],
[50,"0.74"]
]
}
}
上面的 JSON 被解析为以下键和值
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" |
可下载的演示程序通过“URL 转文件”按钮将三个 URL 中的一个加载到文本文件中。我添加了一些 JSON 源作为参考。“解析文件”按钮然后加载这些文本文件，并将 JSON 数据解析到电子表格的 Sheet2 中。
历史
- Rev 1.0 - 初始发布
- Rev 1.1 - 更新以正确解析后面跟着 '
]' 或 '}' 控制字符的数字值。这些值在初始版本中被忽略。