基于 字典 对象实现的 vb json 类。代码源自网络（出处地址在下面的代码里面），我做了一些修复和优化。
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cJson"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'Author: Demon
'Date: 2012/5/3
'Website: http://demon.tw
' 引用了Microsoft Scripting Runtime
'创建了Microsoft VBScript Regular Expressions 5.5
'修改：邓伟
' 【20190702】
' 加入字典复制函数，便于数组层的字典赋值的时候拷贝副本
' 内置字典对象 Dic ，便于外部直接使用。
Public Dic_en As New Scripting.Dictionary
Public Dic_de As New Scripting.Dictionary
Dim Fso As New Scripting.FileSystemObject
Private Whitespace, NumberRegex, StringChunk
Private b, f, r, n, T
Public Enum EumnJsonSun
JSONArray
JSONObject
End Enum
Public Function LoadFrom(ByVal Url As String) As Boolean
'by邓伟
Dim TS As Scripting.TextStream
Set TS = Fso.OpenTextFile(Url)
Dim Txt As String: Txt = TS.ReadAll()
LoadFrom = Decode(Txt)
TS.Close
End Function
'
Public Function SaveTo(ByVal FileName As String, Content, Optional AsUtf8 As Boolean = True) As Variant
'by邓伟
Dim TS As Scripting.TextStream
Set TS = Fso.OpenTextFile(FileName, ForWriting, True)
TS.Write Content
TS.Close
End Function
Public Function NewJsonSun(SunType As EumnJsonSun)
'by邓伟，
If SunType = JSONArray Then
NewJsonSun = Array()
Else
Set NewJsonSun = New Scripting.Dictionary
End If
End Function
Public Function pushDic(srcDic As Scripting.Dictionary, dstDic As Scripting.Dictionary, dstDicArrayKey$) As Boolean
'by邓伟，push字典对象到某个数组字典里面，成为子级
Dim Arr: Arr = dstDic(dstDicArrayKey)
Dim Max&: Max = UBound(Arr) + 1
' If Max > 0 Then Max = Max + 1
ReDim Preserve Arr(Max)
Set Arr(Max) = srcDic
dstDic(dstDicArrayKey) = Arr
' Set srcDic = Nothing
pushDic = True
End Function
Public Function copyDic(srcDic As Scripting.Dictionary, dstDic As Scripting.Dictionary) As Boolean
'by邓伟，复制字典对象
Set dstDic = dicCopy(srcDic)
copyDic = True
End Function
Private Function dicCopy(ByVal Val) As Scripting.Dictionary
'by邓伟，通过递归方法实现的字典副本
Dim objDic As New Scripting.Dictionary
If TypeName(Val) = "Dictionary" Then
For Each x In Val
If TypeName(Val(x)) = "Dictionary" Then
objDic.Add x, dicCopy(Val(x))
Else
objDic.Add x, Val(x)
End If
Next
End If
Set dicCopy = objDic
End Function
Public Function jsDecode(ByVal JSONPath As String, ByVal JSONString As String, Optional isObj As Boolean) As Variant
'by邓伟，基于js脚本解析器实现的json解析，传入需要访问的json路径，返回json节点值。路径语法同js
' Dim a, b, j As New cJson
' a = "{""a"":{""b"":1}}"
' Set b = j.jsDecode("a", a, True)
' MsgBox b.b
On Error GoTo eee
Dim json As Object
Set json = CreateObject("MSScriptControl.ScriptControl")
json.Language = "JScript"
If isObj = True Then
If JSONPath = "" Then
Set jsDecode = json.Eval(JSONString)
Else
Set jsDecode = json.Eval("JSON=" & JSONString & ";JSON." & JSONPath & ";")
End If
Else
jsDecode = json.Eval("JSON=" & JSONString & ";JSON." & JSONPath & ";")
End If
Set json = Nothing
Exit Function
eee:
jsDecode = "vbNull"
End Function
Public Function jsArrayItem(Arr, Index, Optional isObj As Boolean) As Variant
'by 邓伟，由于vb不支持 . 符号直接读取数字索引的数组对象，因此使用该函数来取得
If isObj = True Then
Set jsArrayItem = CallByName(Arr, Index, VbGet)
Else
jsArrayItem = CallByName(Arr, Index, VbGet)
End If
End Function
Private Sub Command1_Click()
Dim json As New cJson
Dim s$: s = "{""a"": {""arr"": [1,2,3,4,5] }, ""obj"": {""b"": 1} }"
Dim Arr: Set Arr = json.jsDecode("a.arr", s, True)
Dim b&: b = json.jsDecode("obj.b", s, False)
Dim obj: Set obj = json.jsDecode("obj", s, True)
Dim x
For Each x In Arr
Debug.Print x
Next
End Sub
'----------------------------------------------js-----------------------------
Private Sub Class_Initialize()
Whitespace = " " & vbTab & vbCr & vbLf
b = ChrW(8)
f = vbFormFeed
r = vbCr
n = vbLf
T = vbTab
'Set NumberRegex = New RegExp
Set NumberRegex = CreateObject("VBScript.RegExp")
NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?"
NumberRegex.Global = False
NumberRegex.MultiLine = True
NumberRegex.IgnoreCase = True
'Set StringChunk = New RegExp
Set StringChunk = CreateObject("VBScript.RegExp")
StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])"
StringChunk.Global = False
StringChunk.MultiLine = True
StringChunk.IgnoreCase = True
'woeoio 2024-02-02 设置解析对象不区分大小写
Dic_en.CompareMode = 1 ' TextCompare
Dic_de.CompareMode = 1 ' TextCompare
End Sub
'Return a JSON string representation of a VBScript data structure
'Supports the following objects and types
'+-------------------+---------------+
'| VBScript | JSON |
'+===================+===============+
'| Dictionary | object |
'+-------------------+---------------+
'| Array | array |
'+-------------------+---------------+
'| String | string |
'+-------------------+---------------+
'| Number | number |
'+-------------------+---------------+
'| True | true |
'+-------------------+---------------+
'| False | false |
'+-------------------+---------------+
'| Null | null |
'+-------------------+---------------+
Private Function c_Encode(ByRef obj)
Dim buf, i, C, g
Set buf = CreateObject("Scripting.Dictionary")
Select Case VarType(obj)
Case vbNull
buf.Add buf.Count, "null"
Case vbBoolean
If obj Then
buf.Add buf.Count, "true"
Else
buf.Add buf.Count, "false"
End If
Case vbInteger, vbLong, vbSingle, vbDouble
buf.Add buf.Count, obj
Case vbString
buf.Add buf.Count, """"
For i = 1 To Len(obj)
C = Mid(obj, i, 1)
Select Case C
Case """": buf.Add buf.Count, "\"""
Case "\": buf.Add buf.Count, "\\"
Case "/": buf.Add buf.Count, "/"
Case b: buf.Add buf.Count, "\b"
Case f: buf.Add buf.Count, "\f"
Case r: buf.Add buf.Count, "\r"
Case n: buf.Add buf.Count, "\n"
Case T: buf.Add buf.Count, "\t"
Case Else
If AscW(C) >= 0 And AscW(C) <= 31 Then
C = Right("0" & Hex(AscW(C)), 2)
buf.Add buf.Count, "\u00" & C
Else
buf.Add buf.Count, C
End If
End Select
Next
buf.Add buf.Count, """"
Case vbArray + vbVariant
g = True
buf.Add buf.Count, "["
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, c_Encode(i)
Next
buf.Add buf.Count, "]"
Case vbObject
If TypeName(obj) = "Dictionary" Then
g = True
buf.Add buf.Count, "{"
For Each i In obj
If g Then g = False Else buf.Add buf.Count, ","
buf.Add buf.Count, """" & i & """" & ":" & c_Encode(obj(i))
Next
buf.Add buf.Count, "}"
Else
Err.Raise 8732, , "None dictionary object"
End If
Case Else
buf.Add buf.Count, """" & CStr(obj) & """"
End Select
c_Encode = Join(buf.Items, "")
End Function
Public Function Encode(Optional obj) As String
' If VarType(obj) = vbBoolean Then Set obj = Dic_en
If IsMissing(obj) Then Set obj = Dic_en
Encode = c_Encode(obj)
End Function
'Return the VBScript representation of ``str(``
'Performs the following translations in decoding
'+---------------+-------------------+
'| JSON | VBScript |
'+===============+===================+
'| object | Dictionary |
'+---------------+-------------------+
'| array | Array |
'+---------------+-------------------+
'| string | String |
'+---------------+-------------------+
'| number | Double |
'+---------------+-------------------+
'| true | True |
'+---------------+-------------------+
'| false | False |
'+---------------+-------------------+
'| null | Null |
'+---------------+-------------------+
Private Function c_Decode(ByRef str)
Dim idx
idx = SkipWhitespace(str, 1)
If Mid(str, idx, 1) = "{" Then
Set c_Decode = ScanOnce(str, 1)
Else
c_Decode = ScanOnce(str, 1)
End If
End Function
Public Function Decode(ByRef str) As Boolean 'woeoio#20220112 修复数组json对象
If Mid(str, 1, 1) = "{" Then
' Set Decode = c_Decode(str)
Set Dic_de = c_Decode(str)
Else
' Decode = c_Decode(str)
Dic_de.RemoveAll
Dic_de.Add "_ARROBJ_", c_Decode(str)
End If
Decode = True
End Function
Private Function ScanOnce(ByRef str, ByRef idx)
Dim C, ms
idx = SkipWhitespace(str, idx)
C = Mid(str, idx, 1)
If C = "{" Then
idx = idx + 1
Set ScanOnce = ParseObject(str, idx)
Exit Function
ElseIf C = "[" Then
idx = idx + 1
ScanOnce = ParseArray(str, idx)
Exit Function
ElseIf C = """" Then
idx = idx + 1
ScanOnce = ParseString(str, idx)
Exit Function
ElseIf C = "n" And StrComp("null", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = Null
Exit Function
ElseIf C = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then
idx = idx + 4
ScanOnce = True
Exit Function
ElseIf C = "f" And StrComp("false", Mid(str, idx, 5)) = 0 Then
idx = idx + 5
ScanOnce = False
Exit Function
End If
Set ms = NumberRegex.Execute(Mid(str, idx))
If ms.Count = 1 Then
idx = idx + ms(0).length
ScanOnce = ms(0)
' ScanOnce = """" & ms(0)
'Debug.Print ScanOnce
Exit Function
End If
Err.Raise 8732, , "No JSON object could be ScanOnced"
End Function
Private Function ParseObject(ByRef str, ByRef idx)
Dim C, Key, Value
Set ParseObject = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
C = Mid(str, idx, 1)
If C = "}" Then
idx = idx + 1 '20220109#woeoio 修复了对象为空的bug
Exit Function
ElseIf C <> """" Then
Err.Raise 8732, , "Expecting property name"
End If
idx = idx + 1
Do
Key = ParseString(str, idx)
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) <> ":" Then
Err.Raise 8732, , "Expecting : delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
If Mid(str, idx, 1) = "{" Then
Set Value = ScanOnce(str, idx)
Else
Value = ScanOnce(str, idx)
End If
'If VarType(Value) = 5 Then
If Key = "id" Then
ParseObject.Add Key, Value
'ParseObject.Add key, """" & Value & """"
Else
ParseObject.Add Key, Value
End If
'Debug.Print key & "--" & VarType(Value) & "--" & Value
'
' If VarType(Value) = 8204 Then
' idx = SkipWhitespace(str, idx)
' c = Mid(str, idx, 1)
' Debug.Print Join(ParseObject.Items, "------")
' Exit Do
' End If
idx = SkipWhitespace(str, idx)
C = Mid(str, idx, 1)
If C = "}" Then
Exit Do
ElseIf C = "]" Then
Exit Do
ElseIf C <> "," Then
'Debug.Print c
Err.Raise 8732, , "Expecting , delimiter"
End If
idx = SkipWhitespace(str, idx + 1)
C = Mid(str, idx, 1)
If C <> """" Then
Err.Raise 8732, , "Expecting property name"
End If
idx = idx + 1
Loop
idx = idx + 1
End Function
Private Function ParseArray(ByRef str, ByRef idx)
Dim C, values, Value, d
Set values = CreateObject("Scripting.Dictionary")
idx = SkipWhitespace(str, idx)
C = Mid(str, idx, 1)
d = Mid(str, idx + 1, 1)
If d = "]" Then
ParseArray = values.Items
Exit Function
End If
If C = "]" Then
ParseArray = values.Items
Exit Function
End If
Do
idx = SkipWhitespace(str, idx)
If Mid(str, idx, 1) = "{" Then
Set Value = ScanOnce(str, idx)
Else
Value = ScanOnce(str, idx)
End If
values.Add values.Count, Value
idx = SkipWhitespace(str, idx)
C = Mid(str, idx, 1)
If C = "]" Then
Exit Do
' ElseIf c = "}" Then
' Exit Do
ElseIf C <> "," Then
Err.Raise 8732, , "Expecting , delimiter"
End If
idx = idx + 1
Loop
idx = idx + 1
ParseArray = values.Items
End Function
Private Function ParseString(ByRef str, ByRef idx)
Dim chunks, Content, terminator, ms, esc, Char
Set chunks = CreateObject("Scripting.Dictionary")
Do
Set ms = StringChunk.Execute(Mid(str, idx))
If ms.Count = 0 Then
Err.Raise 8732, , "Unterminated string starting"
End If
Content = ms(0).Submatches(0)
terminator = ms(0).Submatches(1)
If Len(Content) > 0 Then
chunks.Add chunks.Count, Content
End If
idx = idx + ms(0).length
If terminator = """" Then
Exit Do
ElseIf terminator <> "\" Then
Err.Raise 8732, , "Invalid control character"
End If
esc = Mid(str, idx, 1)
If esc <> "u" Then
Select Case esc
Case """": Char = """"
Case "\": Char = "\"
Case "/": Char = "/"
Case "b": Char = b
Case "f": Char = f
Case "n": Char = n
Case "r": Char = r
Case "t": Char = T
Case Else: Err.Raise 8732, , "Invalid escape"
End Select
idx = idx + 1
Else
Char = ChrW("&H" & Mid(str, idx + 1, 4))
idx = idx + 5
End If
chunks.Add chunks.Count, Char
Loop
ParseString = Join(chunks.Items, "")
'Debug.Print ParseString
End Function
Private Function SkipWhitespace(ByRef str, ByVal idx)
Do While idx <= Len(str) And _
InStr(Whitespace, Mid(str, idx, 1)) > 0
idx = idx + 1
Loop
SkipWhitespace = idx
End Function
使用方法：
把上面的代码复制，保存为 cJson.cls 然后在vb过程引入这个类文件，并且引用以下系统字典组件
接下来进行实例化，就可以开始使用了：
解析json字符串到字典：
Private Sub Command1_Click()
Dim json As New cJson
Dim s$: s = "{""a"": {""arr"": [1,2,3,4,5] }, ""obj"": {""b"": 1} }"
If json.Decode(s) = True Then
'成功解析则使用
MsgBox json.Dic_de("a")("arr")(3)
End If
End Sub从字典生成json字符串
Option Explicit
Private Sub Command1_Click()
Dim json As New cJson
Dim s$: s = "{""a"": {""arr"": [1,2,3,4,5] }, ""obj"": {""b"": 1} }"
If json.Decode(s) = True Then
'成功解析则使用
MsgBox json.Dic_de("a")("arr")(3)
'把字典对象修改后转为json字符串
json.Dic_de("obj")("b") = "新的值"
MsgBox json.Encode(json.Dic_de)
End If
End Sub把字典保存为 json 文件
Option Explicit
Private Sub Command1_Click()
Dim json As New cJson
Dim s$: s = "{""a"": {""arr"": [1,2,3,4,5] }, ""obj"": {""b"": 1} }"
If json.Decode(s) = True Then
'成功解析则使用
MsgBox json.Dic_de("a")("arr")(3)
'把字典对象修改后转为json字符串
json.Dic_de("obj")("b") = "新的值"
Dim JsonStr As String: JsonStr = json.Encode(json.Dic_de)
MsgBox JsonStr
'把字典对象写入磁盘文件
json.SaveTo "test.json", JsonStr
End If
End Sub
从json文件加载字符串到字典
Option Explicit
Private Sub Command1_Click()
Dim json As New cJson
Dim s$: s = "{""a"": {""arr"": [1,2,3,4,5] }, ""obj"": {""b"": 1} }"
If json.Decode(s) = True Then
'成功解析则使用
MsgBox json.Dic_de("a")("arr")(3)
'把字典对象修改后转为json字符串
json.Dic_de("obj")("b") = "新的值"
Dim JsonStr As String: JsonStr = json.Encode(json.Dic_de)
MsgBox JsonStr
'把字典对象写入磁盘文件
json.SaveTo "test.json", JsonStr
'从json文件加载字符串到字典
json.LoadFrom "test.json"
MsgBox json.Dic_de("obj")("b")
End If
End Sub
Views: 120
