未分类

vb6使用字典实现的JSON解析和生成类

基于 字典 对象实现的 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

这里再加一个更容易理解的例子,,(,因为上面的示例,群友们说不好理解)

    Dim json As New cJson
    '构造 jsn1 和 jsn2
    Dim jsn1 As New Scripting.Dictionary
    jsn1("姓名") = "张三"
    jsn1("年龄") = 25
    Dim jsn2 As New Scripting.Dictionary
    jsn2("姓名") = "张三"
    jsn2("年龄") = 26
    '放入到一个数组
    Dim objArr(): objArr = Array(jsn1, jsn2)
    '最后放入一个根对象
    Dim cJsn As New Scripting.Dictionary
    cJsn("新对象键名") = objArr
    '把对象转为字符串显示
    Debug.Print json.Encode(cJsn)

这里还有一个我早期写的 网络请求 json 的示例:

vb6网络webapi读写(POST和GET)DemoByVI – VB6.PRO
https://vb6.pro/vi/1146

Views: 219

Hi, I’m 邓伟

本来无一物,何处惹尘埃

发表回复