'引用 Microsoft Scripting Runtime，Dim s As New Dictionary
'或者 CreateObject("Scripting.Dictionary")
'未考虑\[ \] 的转义情况
'基本思路：解析JSON格式数据主要是处理{}和[]的嵌套关系
' 先把[]替换成特定字符，处理{}部分
' 在处理[]里面部分，分析有多少个{}，再重复前面步骤
'主函数：通过JSON字符串解析成字段类型的数据
Public Function GetJsonObject(JsonData As String) As Object
'定义一个字典用于临时储存数组部分的内容
Dim dicSave As Object
Set dicSave = CreateObject("Scripting.Dictionary")
Dim lngFindStart As Long
Dim lngFindEnd As Long
Dim i As Long, j As Long '循环控制变量
'去掉最外层的大括号
If Left(JsonData, 1) = "{" Then JsonData = Right(JsonData, Len(JsonData) - 1)
If Right(JsonData, 1) = "}" Then JsonData = Left(JsonData, Len(JsonData) - 1)
''判断是否有[], 处理有数组的情况
lngFindStart = InStr(1, JsonData, "[")
i = 0
Do While lngFindStart > 0
i = i + 1
lngFindEnd = GetPosition(JsonData, "[", "]", lngFindStart)
If lngFindEnd = 0 Then Exit Function '如果返回0，说明JSON格式不正确
dicSave.Add "#" & i, Mid(JsonData, lngFindStart,
lngFindEnd - lngFindStart + 1) '把数组内容存到字典
JsonData
= Left(JsonData, lngFindStart - 1) & "#" & i & Right(JsonData, Len(JsonData) - lngFindEnd)
'替换JSON的数组内容为 #Num
lngFindStart = InStr(1, JsonData, "[")
Loop
'处理数组的情况之后，就可以对无数组的JSON分列处理
Dim dicJsonObject As Object
Dim arr() As String
Dim strJsonItemName As String
Dim strJsonItemValue As String
Dim strJsonLastName As String '上一个项目的名称
Set dicJsonObject = CreateObject("Scripting.Dictionary")
arr = Split(JsonData, ",")
'遍历JSON数据项目
For i = 0 To UBound(arr)
strJsonItemName = GetJsonItemName(arr(i))
strJsonItemValue = GetJsonItemValue(arr(i))
'若名称不为空，则记录一下名称
If Len(strJsonItemName) > 0 Then strJsonLastName = strJsonItemName
'判断是否内容是数组
If Left(strJsonItemValue, 1) = "#" Then
'判断里面有几个最外层的{}，创建Dictionary数组
Dim GetSubJson As Object
Set GetSubJson = GetSubJsons(dicSave(strJsonItemValue))
If GetSubJson.Count = 0 Then
'普通数组，直接新增（mid函数是为了去掉外层[]符号
dicJsonObject.Add strJsonItemName, Split(Mid(dicSave(strJsonItemValue),
2, Len(dicSave(strJsonItemValue)) - 2), ",")
Else
'有多个{}，创建Dictionary数组
Dim dicSubJson() As Object
ReDim dicSubJson(GetSubJson.Count - 1) As Object
For j = 0 To GetSubJson.Count - 1
Set dicSubJson(j) = GetJsonObject(GetSubJson("#" & j)) '使用递归，逐层解析
Next
dicJsonObject.Add strJsonItemName, dicSubJson
End If
Else
'非数组就直接新增
If Len(strJsonItemName) > 0 Then
dicJsonObject.Add strJsonItemName, strJsonItemValue
Else
dicJsonObject(strJsonLastName) = dicJsonObject(strJsonLastName) & "," & strJsonItemValue
End If
End If
Next
Set GetJsonObject = dicJsonObject
End Function
'判断有多少个最外层的{}，分隔，返回一个String数组
Private Function GetSubJsons(SubJsonData As String) As Object
Dim dicSave As Object '定义一个字典用于临时储存{}部分的内容
Set dicSave = CreateObject("Scripting.Dictionary")
Dim lngFindStart As Long
Dim lngFindEnd As Long
Dim i As Long
lngFindStart = InStr(1, SubJsonData, "{")
i = 0
Do While lngFindStart > 0
i = i + 1
lngFindEnd = GetPosition(SubJsonData, "{", "}", lngFindStart)
If lngFindEnd = 0 Then Exit Function '如果返回0，说明JSON格式不正确
'把数组内容存到字典
dicSave.Add "#" & i - 1, Mid(SubJsonData, lngFindStart, lngFindEnd - lngFindStart + 1)
lngFindStart = InStr(lngFindEnd + 1, SubJsonData, "{")
Loop
Set GetSubJsons = dicSave
End Function
'获取JSON项目的名称
Private Function GetJsonItemName(JsonItem As String) As String
Dim lngStart As Long
Dim lngEnd As Long
lngStart = InStr(1, JsonItem, """")
lngEnd = InStr(lngStart + 1, JsonItem, """")
If lngEnd <= lngStart Then Exit Function
GetJsonItemName = Mid(JsonItem, lngStart + 1, lngEnd - lngStart - 1)
End Function
'获取JSON项目的数据
Private Function GetJsonItemValue(JsonItem As String) As String
Dim lngStart As Long
Dim strReturn As String
lngStart = InStr(1, JsonItem, ":")
If lngStart = 0 Then
GetJsonItemValue = JsonItem
Exit Function
End If
strReturn = Trim(Right(JsonItem, Len(JsonItem) - lngStart))
If Left(strReturn, 1) = """" Then strReturn = Right(strReturn, Len(strReturn) - 1)
If Right(strReturn, 1) = """" Then strReturn = Left(strReturn, Len(strReturn) - 1)
GetJsonItemValue = strReturn
End Function
'获取下一个 ] 的位置
'str:Json字符串
'startChar:判断开始的字符 例如 [
'endChar:判断结束的字符 例如 ]
'lngStart: [ 开始的位置
Private Function GetPosition(str As String,
startChar As String, endChar As String, lngStart As Long) As Long
Dim lngNextStart As Long '下一个 [ 的位置
Dim lngNextEnd As Long '下一个 ] 的位置
'在 [ 不为0的情况下，判断 ] 的位置是否小于 [ 的位置
lngNextStart = InStr(lngStart + 1, str, startChar)
lngNextEnd = InStr(lngStart + 1, str, endChar)
If lngNextStart = 0 Then
GetPosition = lngNextEnd
Exit Function
End If
If lngNextStart > lngNextEnd Then
GetPosition = lngNextEnd
Else
GetPosition = GetPosition(str, startChar, endChar, lngNextEnd) '使用递归，逐层解析
End If
End Function