VBA, json解读,表结构-json字符串互转

说明: 不依赖MSScriptControl.ScriptControl,网上收一大堆都是需要依赖MSScriptControl.ScriptControl,但是经常提示"类未注册".

WriteJson 将结构体转json字符串

        vb中对象需要set, 所以不管根节点是字典还是数组,都封装了一层数组.所以永远返回数组arr.

arr只有1个元素 ,判断arr(0)的类型, 字符串型表示error提示, object 或者数组即为成功. arr(0)是json的根节点.

writejson

        结构转字符串, 接收arr(0)这样的参数, 不需要加数组的壳.

Option Explicit

Sub JsonTest()
    Dim strJsonString As String
    Dim varJson As Variant
    Dim strState As String
    Dim varItem As Variant
 
    strJsonString = "{""a"":[{}, 0, ""value"", [{""stuff"":""content""}]], b:null}"
    
    ParseJson strJsonString, varJson, strState

    
    Debug.Print varJson.Count
    
    
    ' traversing each element in array
    For Each varItem In varJson("a")
        
        MsgBox "The structure of the element:" & vbCrLf & BeautifyJson(varItem)
    Next

    ' show the full structure starting from root element
    MsgBox "The full structure starting from root element:" & vbCrLf & BeautifyJson(varJson)

End Sub



Sub ReadJson(ByVal strContent As String)
    Dim varJson As Variant
    Dim strState As String
    Dim objTokens As Object
    Dim objRegEx As Object
    Dim bMatched As Boolean
    
    Set objTokens = CreateObject("Scripting.Dictionary")
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
        
        
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
    
    
    
    Dim jsonArr(0)
    If strState = "Object" Then
     Set jsonArr(0) = varJson
    ElseIf strState = "Error" Then
         jsonArr(0) = strState
    Else
        jsonArr(0) = varJson
         
    End If
      ReadJson = jsonArr
    
    
    
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)

                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

Function BeautifyJson(varJson As Variant) As String
    Dim strResult As String
    Dim lngIndent As Long
    BeautifyJson = ""
    lngIndent = 0
    BeautyTraverse BeautifyJson, lngIndent, varJson, vbTab, 1
End Function

Sub BeautyTraverse(strResult As String, lngIndent As Long, varElement As Variant, strIndent As String, lngStep As Long)
    Dim arrKeys() As Variant
    Dim lngIndex As Long
    Dim strTemp As String

    Select Case VarType(varElement)
        Case vbObject
            If varElement.Count = 0 Then
                strResult = strResult & "{}"
            Else
                strResult = strResult & "{" & vbCrLf
                lngIndent = lngIndent + lngStep
                arrKeys = varElement.Keys
                For lngIndex = 0 To UBound(arrKeys)
                    strResult = strResult & String(lngIndent, strIndent) & """" & arrKeys(lngIndex) & """" & ": "
                    BeautyTraverse strResult, lngIndent, varElement(arrKeys(lngIndex)), strIndent, lngStep
                    If Not (lngIndex = UBound(arrKeys)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "}"
            End If
        Case Is >= vbArray
            If UBound(varElement) = -1 Then
                strResult = strResult & "[]"
            Else
                strResult = strResult & "[" & vbCrLf
                lngIndent = lngIndent + lngStep
                For lngIndex = 0 To UBound(varElement)
                    strResult = strResult & String(lngIndent, strIndent)
                    BeautyTraverse strResult, lngIndent, varElement(lngIndex), strIndent, lngStep
                    If Not (lngIndex = UBound(varElement)) Then strResult = strResult & ","
                    strResult = strResult & vbCrLf
                Next
                lngIndent = lngIndent - lngStep
                strResult = strResult & String(lngIndent, strIndent) & "]"
            End If
        Case vbInteger, vbLong, vbSingle, vbDouble
            strResult = strResult & varElement
        Case vbNull
            strResult = strResult & "Null"
        Case vbBoolean
            strResult = strResult & IIf(varElement, "True", "False")
        Case Else
            strTemp = Replace(varElement, "\""", """")
            strTemp = Replace(strTemp, "\", "\\")
            strTemp = Replace(strTemp, "/", "\/")
            strTemp = Replace(strTemp, Chr(8), "\b")
            strTemp = Replace(strTemp, Chr(12), "\f")
            strTemp = Replace(strTemp, vbLf, "\n")
            strTemp = Replace(strTemp, vbCr, "\r")
            strTemp = Replace(strTemp, vbTab, "\t")
            strResult = strResult & """" & strTemp & """"
    End Select

End Sub

Function ReadTextFile(strPath As String, lngFormat As Long) As String
    ' lngFormat -2 - System default, -1 - Unicode, 0 - ASCII
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 1, False, lngFormat)
        ReadTextFile = ""
        If Not .AtEndOfStream Then ReadTextFile = .ReadAll
        .Close
    End With
End Function

Sub WriteTextFile(strContent As String, strPath As String, lngFormat As Long)
    With CreateObject("Scripting.FileSystemObject").OpenTextFile(strPath, 2, True, lngFormat)
        .Write (strContent)
        .Close
    End With
End Sub