以下是 VB6 中解析 JSON 字符串的示例代码：
```VB
Option Explicit
Private Type JsonElement
Key As String
Value As Variant
End Type
Private Function ParseJson(ByVal json As String) As Collection
Dim elements As New Collection
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = 1
Do While i <= jsonLen
Dim c As String
c = Mid(json, i, 1)
If c = "{" Then ' Object
Dim obj As New Collection
i = ParseObject(json, i + 1, obj)
elements.Add obj
ElseIf c = "[" Then ' Array
Dim arr As New Collection
i = ParseArray(json, i + 1, arr)
elements.Add arr
ElseIf c = """" Then ' String
Dim value As String
i = ParseString(json, i + 1, value)
elements.Add value
ElseIf c Like "[0-9-]" Then ' Number
Dim value As Variant
i = ParseNumber(json, i, value)
elements.Add value
ElseIf c = "t" Or c = "f" Then ' Boolean
Dim value As Variant
i = ParseBoolean(json, i, value)
elements.Add value
ElseIf c = "n" Then ' Null
Dim value As Variant
i = ParseNull(json, i, value)
elements.Add value
End If
i = i + 1
Loop
Set ParseJson = elements
End Function
Private Function ParseObject(ByVal json As String, ByVal startIndex As Long, ByRef obj As Collection) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
Do While i <= jsonLen
Dim c As String
c = Mid(json, i, 1)
If c = "}" Then ' End of object
Exit Do
If c = """" Then ' Key
Dim key As String
i = ParseString(json, i + 1, key)
i = SkipWhitespace(json, i)
If Mid(json, i, 1) <> ":" Then
Err.Raise 1001, , "Invalid JSON format: expected colon after object key"
End If
i = SkipWhitespace(json, i + 1)
Dim value As Variant
If Mid(json, i, 1) = "{" Then ' Object
Dim childObj As New Collection
i = ParseObject(json, i + 1, childObj)
value = childObj
ElseIf Mid(json, i, 1) = "[" Then ' Array
Dim arr As New Collection
i = ParseArray(json, i + 1, arr)
value = arr
ElseIf Mid(json, i, 1) = """" Then ' String
i = ParseString(json, i + 1, value)
ElseIf Mid(json, i, 1) Like "[0-9-]" Then ' Number
i = ParseNumber(json, i, value)
ElseIf Mid(json, i, 1) = "t" Or Mid(json, i, 1) = "f" Then ' Boolean
i = ParseBoolean(json, i, value)
ElseIf Mid(json, i, 1) = "n" Then ' Null
i = ParseNull(json, i, value)
End If
obj.Add value, key
End If
i = i + 1
Loop
ParseObject = i
End Function
Private Function ParseArray(ByVal json As String, ByVal startIndex As Long, ByRef arr As Collection) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
Do While i <= jsonLen
Dim c As String
c = Mid(json, i, 1)
If c = "]" Then ' End of array
Exit Do
Dim value As Variant
If c = "{" Then ' Object
Dim childObj As New Collection
i = ParseObject(json, i + 1, childObj)
value = childObj
ElseIf c = "[" Then ' Array
Dim childArr As New Collection
i = ParseArray(json, i + 1, childArr)
value = childArr
ElseIf c = """" Then ' String
i = ParseString(json, i + 1, value)
ElseIf c Like "[0-9-]" Then ' Number
i = ParseNumber(json, i, value)
ElseIf c = "t" Or c = "f" Then ' Boolean
i = ParseBoolean(json, i, value)
ElseIf c = "n" Then ' Null
i = ParseNull(json, i, value)
End If
arr.Add value
i = SkipWhitespace(json, i)
If Mid(json, i, 1) = "," Then
i = i + 1
ElseIf Mid(json, i, 1) <> "]" Then
Err.Raise 1002, , "Invalid JSON format: expected comma or end of array"
End If
Loop
ParseArray = i
End Function
Private Function ParseString(ByVal json As String, ByVal startIndex As Long, ByRef value As String) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
Do While i <= jsonLen
Dim c As String
c = Mid(json, i, 1)
If c = """" Then ' End of string
Exit Do
If c = "\" Then ' Escape sequence
Dim nextChar As String
nextChar = Mid(json, i + 1, 1)
If nextChar = """" Then
value = value & """"
i = i + 1
ElseIf nextChar = "\" Then
value = value & "\"
i = i + 1
ElseIf nextChar = "/" Then
value = value & "/"
i = i + 1
ElseIf nextChar = "b" Then
value = value & vbBack
i = i + 1
ElseIf nextChar = "f" Then
value = value & vbFormFeed
i = i + 1
ElseIf nextChar = "n" Then
value = value & vbNewLine
i = i + 1
ElseIf nextChar = "r" Then
value = value & vbCr
i = i + 1
ElseIf nextChar = "t" Then
value = value & vbTab
i = i + 1
ElseIf nextChar = "u" Then
Dim hexCode As String
hexCode = Mid(json, i + 2, 4)
value = value & ChrW("&H" & hexCode)
i = i + 5
Else
Err.Raise 1003, , "Invalid JSON format: unknown escape sequence"
End If
Else
value = value & c
End If
i = i + 1
Loop
ParseString = i
End Function
Private Function ParseNumber(ByVal json As String, ByVal startIndex As Long, ByRef value As Variant) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
Do While i <= jsonLen
Dim c As String
c = Mid(json, i, 1)
If c Like "[0-9-+eE.]" Then
value = value & c
ElseIf c Like "[ },\]]" Then ' End of number
Exit Do
Else
Err.Raise 1004, , "Invalid JSON format: unexpected character in number"
End If
i = i + 1
Loop
value = CDbl(value)
ParseNumber = i - 1
End Function
Private Function ParseBoolean(ByVal json As String, ByVal startIndex As Long, ByRef value As Variant) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
If Mid(json, i, 4) = "true" Then
value = True
ParseBoolean = i + 3
ElseIf Mid(json, i, 5) = "false" Then
value = False
ParseBoolean = i + 4
Else
Err.Raise 1005, , "Invalid JSON format: expected boolean"
End If
End Function
Private Function ParseNull(ByVal json As String, ByVal startIndex As Long, ByRef value As Variant) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
If Mid(json, i, 4) = "null" Then
value = Null
ParseNull = i + 3
Else
Err.Raise 1006, , "Invalid JSON format: expected null"
End If
End Function
Private Function SkipWhitespace(ByVal json As String, ByVal startIndex As Long) As Long
Dim jsonLen As Long
Dim i As Long
jsonLen = Len(json)
i = startIndex
Do While i <= jsonLen And Mid(json, i, 1) Like "[ ]"
i = i + 1
Loop
SkipWhitespace = i
End Function
```
使用示例：
```VB
Dim json As String
json = "{""name"":""John"",""age"":30,""city"":""New York"",""pets"":[""dog"",""cat""]}"
Dim elements As Collection
Set elements = ParseJson(json)
Debug.Print elements("name") ' Output: John
Debug.Print elements("age") ' Output: 30
Debug.Print elements("city") ' Output: New York
Debug.Print elements("pets")(1) ' Output: cat
```
496
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
