Results 1 to 7 of 7

Thread: [VB6/VBA] JSON parsing to built-in VBA.Collections

  1. #1

    Thread Starter
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,044

    [VB6/VBA] JSON parsing to built-in VBA.Collections

    These are x64 and 32-bit implementations (github too) of JSON parsing/dumping functions that are using instances of built-in VBA.Collection to represent both composite JSON objects and arrays. The module allows to switch to alternative internal representation using Scripting.Dictionary for the JSON objects/arrays although these usually require more memory and are slower for JSONs above certain size.

    To remain agnostic to this dual internal representation the module implements an accessor property JsonItem for getting and setting JSON values (e.g. JsonItem(oJson, "path/to/key") = 42) and JsonKeys to enumerate JSON object's keys (this works for arrays too). JsonItem can be used with "wildcard" keys like this vArray = JsonItem(oJson, "receiver/phones/*/number") to return array of numbers from all entries in the phones JSON array.

    Another set of helper functions are JsonTo/FromXmlDocument which as the names suggest can be used to transcode to/from XML (e.g. when accessing SOAP services).

    thinBasic Code:
    1. Option Explicit
    2. DefObj A-Z
    3. Private Const MODULE_NAME As String = "mdJson"
    4.  
    5. #Const ImplScripting = JSON_USE_SCRIPTING <> 0
    6. #Const ImplUseShared = DebugMode <> 0
    7.  
    8. #Const HasPtrSafe = (VBA7 <> 0)
    9. #Const LargeAddressAware = (Win64 = 0 And VBA7 = 0 And VBA6 = 0 And VBA5 = 0)
    10.  
    11. ' See gist in link above
    cheers,
    </wqw>

  2. #2

    Thread Starter
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,044

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    Will post some sample code here

    1. Using JsonItem and JsonKeys
    thinBasic Code:
    1. Option Explicit
    2.  
    3. Sub Main()
    4.     '--- 1. Never explicitly set oJson references to New instances when
    5.     '---    `JsonItem` can create JSON objects for you
    6.    
    7.         Dim oJson As Object
    8.         JsonItem(oJson, "path/to/prop") = 42
    9.         Debug.Print JsonDump(oJson)
    10.         ' -> { "path": { "to": { "prop": 42 } } }
    11.    
    12.     '--- 2. Simple way to get an empty JSON object w/ no properties
    13.    
    14.         Dim oEmpty As Object
    15.         JsonItem(oEmpty, vbNullString) = Empty
    16.         Debug.Print JsonDump(oEmpty)
    17.         ' -> { }
    18.  
    19.     '--- 3. Simple way to get an empty JSON array
    20.    
    21.         Set oEmpty = Nothing
    22.         JsonItem(oEmpty, -1) = Empty
    23.         Debug.Print JsonDump(oEmpty)
    24.         ' -> [ ]
    25.    
    26.     '--- 4. Easily append items to a JSON array by assign to -1 index
    27.    
    28.         JsonItem(oJson, "path/to/array/-1") = 5
    29.         JsonItem(oJson, "path/to/array/-1") = 10
    30.         JsonItem(oJson, "path/to/array/-1") = 42
    31.         Debug.Print JsonDump(JsonItem(oJson, "path/to/array"))
    32.         ' -> [ 5, 10, 42 ]
    33.    
    34.     '--- 5. Convert JSON array to VB6 array by using * index
    35.    
    36.         JsonItem(oJson, "path/to/array/-1") = 2
    37.         JsonItem(oJson, "path/to/array/-1") = 3
    38.         Debug.Print Join(JsonItem(oJson, "path/to/array/*"), ", ")
    39.         ' -> 5, 10, 42, 2, 3
    40.    
    41.     '--- 6. Create JSON array of JSON objects and assign `number` property in one statement
    42.    
    43.         JsonItem(oJson, "path/to/array/*/number") = Array(1, 2, 3, 4, 5)
    44.         Debug.Print JsonDump(JsonItem(oJson, "path/to/array"))
    45.         ' -> [ { "number": 1 }, { "number": 2 }, { "number": 3 }, { "number": 4 }, { "number": 5 } ]
    46.    
    47.         Debug.Print JsonDump(oJson)
    48.         ' -> {
    49.         '        "path": {
    50.         '            "to": {
    51.         '                "prop": 42,
    52.         '                "array": [ { "number": 1 }, { "number": 2 }, { "number": 3 }, { "number": 4 }, { "number": 5 } ]
    53.         '            }
    54.         '        }
    55.         '    }
    56.        
    57.     '--- 7. Get JSON object keys as a VB6 array (works for JSON arrays too)
    58.    
    59.         JsonItem(oJson, "path/to/test") = "Now is " & Now
    60.         Debug.Print Join(JsonKeys(oJson, "path/to"), ", ")
    61.         ' -> prop, array, test
    62.    
    63.     '--- 8. Remove an item by assigning `Empty`
    64.        
    65.         JsonItem(oJson, "path/to/test") = Empty
    66.         Debug.Print Join(JsonKeys(oJson, "path/to"), ", ")
    67.         ' -> prop, array
    68.    
    69.     '--- 9. Test item for existence w/ `IsEmpty`
    70.        
    71.         Debug.Print IsEmpty(JsonItem(oJson, "path/to/nothing"))
    72.         ' -> True
    73.    
    74.     '--- 10. Reference an item as a separate JSON object and dump its keys
    75.        
    76.         Dim oItem As Object
    77.         Set oItem = JsonItem(oJson, "path/to")
    78.         Debug.Print Join(JsonKeys(oItem), ", ")
    79.         ' -> prop, array
    80.        
    81.     '--- 11. Get JSON array elements count
    82.        
    83.         Debug.Print JsonItem(oJson, "path/to/array/-1")
    84.         ' -> 5
    85.        
    86.     '--- 12. Get JSON array elements count alternative
    87.    
    88.         Debug.Print UBound(JsonKeys(oJson, "path/to/array")) + 1
    89.         ' -> 5
    90.        
    91.     '--- 13. Enumerate JSON array elements
    92.    
    93.         Dim vElem As Variant
    94.         For Each vElem In JsonKeys(oJson, "path/to/array")
    95.             Debug.Print "[" & vElem & "]: " & JsonItem(oJson, "path/to/array/" & vElem & "/number") & ", ";
    96.         Next
    97.         ' -> [0]: 1, [1]: 2, [2]: 3, [3]: 4, [4]: 5,
    98. End Sub
    cheers,
    </wqw>

  3. #3
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    429

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    can't open "https://gist.github.com/wqweto/e92dce63a68cd3ff9ca91b053b9510c9"
    can you upload this code?thank you

    my code maybe not same,and i don't khnow how to use:jsonobject to string,like :JSON.stringify(JsonObj)

    Code:
    Option Explicit
    
    Private Const MODULE_NAME As String = "mdJson"
    
    '=========================================================================
    ' API
    '=========================================================================
    
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Public Type JsonContext
        Text() As Integer
        Pos As Long
        Error As String
        LastChar As Integer
    End Type
    
    '=========================================================================
    ' Error management
    '=========================================================================
    Private Sub RaiseError(sFunction As String)
        '    PushError
        '    PopRaiseError sFunction, MODULE_NAME
        Err.Raise Err.Number, MODULE_NAME & "." & sFunction & vbCrLf & Err.Source, Err.Description
    End Sub
    Private Sub PrintError(sFunction As String)
        '    PushError
        '    PopPrintError sFunction, MODULE_NAME
        'debug.print MODULE_NAME & "." & sFunction & ": " & Err.Description, Timer
    End Sub
    
    '=========================================================================
    ' Functions
    '=========================================================================
      Function pvJsonGetString(uCtx As JsonContext) As String
        Const FUNC_NAME As String = "pvJsonGetString"
        Dim lIdx As Long
        Dim nChar As Integer
        Dim sText As String
    
        On Error GoTo EH
        With uCtx
            For lIdx = 0 To &H7FFFFFFF
                nChar = .Text(.Pos + lIdx)
                Select Case nChar
                Case 0, 34, 92                            ' " \
                    sText = Space$(lIdx)
                    Call CopyMemory(ByVal StrPtr(sText), .Text(.Pos), LenB(sText))
                    pvJsonGetString = pvJsonGetString & sText
                    If nChar <> 92 Then                   ' \
                        .Pos = .Pos + lIdx + 1
                        Exit For
                    End If
                    lIdx = lIdx + 1
                    nChar = .Text(.Pos + lIdx)
                    Select Case nChar
                    Case 0
                        Exit For
                    Case 98                               ' b
                        pvJsonGetString = pvJsonGetString & Chr$(8)
                    Case 102                              ' f
                        pvJsonGetString = pvJsonGetString & Chr$(12)
                    Case 110                              ' n
                        pvJsonGetString = pvJsonGetString & vbLf
                    Case 114                              ' r
                        pvJsonGetString = pvJsonGetString & vbCr
                    Case 116                              ' t
                        pvJsonGetString = pvJsonGetString & vbTab
                    Case 117                              ' u
                        pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.Pos + lIdx + 1)) & ChrW$(.Text(.Pos + lIdx + 2)) & ChrW$(.Text(.Pos + lIdx + 3)) & ChrW$(.Text(.Pos + lIdx + 4))))
                        lIdx = lIdx + 4
                    Case 120                              ' x
                        pvJsonGetString = pvJsonGetString & ChrW$(CLng("&H" & ChrW$(.Text(.Pos + lIdx + 1)) & ChrW$(.Text(.Pos + lIdx + 2))))
                        lIdx = lIdx + 2
                    Case Else
                        pvJsonGetString = pvJsonGetString & ChrW$(nChar)
                    End Select
                    .Pos = .Pos + lIdx + 1
                    lIdx = -1
                End Select
            Next
        End With
        Exit Function
    EH:
        RaiseError FUNC_NAME
    End Function
    Public Function JsonParse(sText As String, vResult As Variant, uCtx As JsonContext, Optional Error As String) As Boolean
        Const FUNC_NAME As String = "JsonParse"
        Dim oResult As Object
    
        On Error GoTo EH
        With uCtx
            ReDim .Text(0 To Len(sText)) As Integer
            Call CopyMemory(.Text(0), ByVal StrPtr(sText), LenB(sText))
            JsonParse = pvJsonParse(uCtx, vResult, oResult)
            If Not oResult Is Nothing Then
                Set vResult = oResult
            End If
            Error = .Error
        End With
        Exit Function
    EH:
        PrintError FUNC_NAME
        Resume Next
    End Function
    
    Private Function pvJsonMissing(Optional vMissing As Variant) As Variant
        pvJsonMissing = vMissing
    End Function
    
    Private Function pvJsonParse(uCtx As JsonContext, vResult As Variant, oResult As Object) As Boolean
        '--- note: when using collections change type of parameter oResult to Collection
        #Const USE_RICHCLIENT = False
        #Const USE_COLLECTION = False
        Const FUNC_NAME As String = "pvJsonParse"
        Dim lIdx As Long
        Dim vKey As Variant
        Dim vValue As Variant
        Dim oValue As Object
        Dim sText As String
    
        On Error GoTo EH
        vValue = pvJsonMissing
        With uCtx
            Select Case pvJsonGetChar(uCtx)
            Case 34                                       ' "
                vResult = pvJsonGetString(uCtx)
            Case 91                                       ' [
                #If USE_RICHCLIENT Then
                    #If USE_COLLECTION Then
                        Set oResult = New cCollection
                    #Else
                        Set oResult = New cSortedDictionary
                    #End If
                #Else
                    #If USE_COLLECTION Then
                        Set oResult = New Collection
                    #Else
                        Set oResult = CreateObject("Scripting.Dictionary")
                    #End If
                #End If
                Do
                    Select Case pvJsonGetChar(uCtx)
                    Case 0, 44, 93                        ' , ]
                        If Not oValue Is Nothing Then
                            #If USE_COLLECTION Then
                                oResult.Add oValue
                            #Else
                                oResult.Add lIdx, oValue
                            #End If
                        ElseIf Not IsMissing(vValue) Then
                            #If USE_COLLECTION Then
                                oResult.Add vValue
                            #Else
                                oResult.Add lIdx, vValue
                            #End If
                        End If
                        If .LastChar <> 44 Then           ' ,
                            Exit Do
                        End If
                        lIdx = lIdx + 1
                        vValue = pvJsonMissing
                        Set oValue = Nothing
                    Case Else
                        .Pos = .Pos - 1
                        If Not pvJsonParse(uCtx, vValue, oValue) Then
                            GoTo QH
                        End If
                    End Select
                Loop
            Case 123                                      ' {
                #If USE_RICHCLIENT Then
                    #If USE_COLLECTION Then
                        Set oResult = New cCollection
                    #Else
                        Set oResult = New cSortedDictionary
                        oResult.StringCompareMode = 1     ' TextCompare
                    #End If
                #Else
                    #If USE_COLLECTION Then
                        Set oResult = New Collection
                    #Else
                        Set oResult = CreateObject("Scripting.Dictionary")
                        oResult.CompareMode = 1           ' TextCompare
                    #End If
                #End If
                Do
                    Select Case pvJsonGetChar(uCtx)
                    Case 34                               ' "
                        vKey = pvJsonGetString(uCtx)
                    Case 58                               ' :
                        If Not oValue Is Nothing Then
                            .Error = "Value already specified at position " & .Pos
                            GoTo QH
                        ElseIf Not IsMissing(vValue) Then
                            vKey = vValue
                            vValue = pvJsonMissing
                        End If
                        lIdx = .Pos
                        If Not pvJsonParse(uCtx, vValue, oValue) Then
                            .Pos = lIdx
                            vValue = Empty
                            Set oValue = Nothing
                        End If
                    Case 0, 44, 125                       ' , }
                        If IsMissing(vValue) And oValue Is Nothing Then
                            If IsEmpty(vKey) Then
                                GoTo NoProp
                            End If
                            vValue = vKey
                            vKey = vbNullString
                        End If
                        If IsEmpty(vKey) Then
                            vKey = vbNullString
                        ElseIf IsNull(vKey) Then
                            vKey = "null"
                        End If
                        If Not oValue Is Nothing Then
                            #If USE_COLLECTION Then
                                oResult.Add oValue, vKey & ""
                            #Else
                                oResult.Add vKey & "", oValue
                            #End If
                        Else
                            #If USE_COLLECTION Then
                                oResult.Add vValue, vKey & ""
                            #Else
                                oResult.Add vKey & "", vValue
                            #End If
                        End If
    NoProp:
                        If .LastChar = 0 Then
                            GoTo QH
                        ElseIf .LastChar <> 44 Then       ' ,
                            Exit Do
                        End If
                        vKey = Empty
                        vValue = pvJsonMissing
                        Set oValue = Nothing
                    Case Else
                        .Pos = .Pos - 1
                        If Not pvJsonParse(uCtx, vValue, oValue) Then
                            GoTo QH
                        End If
                    End Select
                Loop
            Case 116, 84                                  ' "t", "T"
                If Not ((.Text(.Pos + 0) Or &H20) = 114 And (.Text(.Pos + 1) Or &H20) = 117 And (.Text(.Pos + 2) Or &H20) = 101) Then
                    GoTo UnexpectedSymbol
                End If
                .Pos = .Pos + 3
                vResult = True
            Case 102, 70                                  ' "f", "F"
                If Not ((.Text(.Pos + 0) Or &H20) = 97 And (.Text(.Pos + 1) Or &H20) = 108 And (.Text(.Pos + 2) Or &H20) = 115 And (.Text(.Pos + 3) Or &H20) = 101) Then
                    GoTo UnexpectedSymbol
                End If
                .Pos = .Pos + 4
                vResult = False
            Case 110, 78                                  ' "n", "N"
                If Not ((.Text(.Pos + 0) Or &H20) = 117 And (.Text(.Pos + 1) Or &H20) = 108 And (.Text(.Pos + 2) Or &H20) = 108) Then
                    GoTo UnexpectedSymbol
                End If
                .Pos = .Pos + 3
                vResult = Null
            Case 48 To 57, 43, 45, 46                     ' 0-9 + - .
                For lIdx = 0 To 1000
                    Select Case .Text(.Pos + lIdx)
                    Case 48 To 57, 43, 45, 46, 101, 69, 120, 88, 97 To 102, 65 To 70    ' 0-9 + - . e E x X a-f A-F
                    Case Else
                        Exit For
                    End Select
                Next
                sText = Space$(lIdx + 1)
                Call CopyMemory(ByVal StrPtr(sText), .Text(.Pos - 1), LenB(sText))
                If LCase$(Left$(sText, 2)) = "0x" Then
                    sText = "&H" & Mid$(sText, 3)
                End If
                On Error GoTo ErrorConvert
                vResult = CDbl(sText)
                On Error GoTo 0
                .Pos = .Pos + lIdx
            Case 0
                If LenB(.Error) <> 0 Then
                    GoTo QH
                End If
            Case Else
                GoTo UnexpectedSymbol
            End Select
            pvJsonParse = True
    QH:
            Exit Function
    UnexpectedSymbol:
            .Error = "Unexpected symbol '" & ChrW$(.LastChar) & "' at position " & .Pos
            Exit Function
    ErrorConvert:
            .Error = Err.Description & " at position " & .Pos
        End With
        Exit Function
    EH:
        RaiseError FUNC_NAME
    End Function
    
    Private Function pvJsonGetChar(uCtx As JsonContext) As Integer
        Const FUNC_NAME As String = "pvJsonGetChar"
        Dim lIdx As Long
    
        On Error GoTo EH
        With uCtx
            Do While .Pos <= UBound(.Text)
                .LastChar = .Text(.Pos)
                .Pos = .Pos + 1
                Select Case .LastChar
                Case 0
                    Exit Function
                Case 9, 10, 13, 32                        ' vbTab, vbCr, vbLf, " "
                    '--- do nothing
                Case 47                                   ' /
                    Select Case .Text(.Pos)
                    Case 47                               ' //
                        .Pos = .Pos + 1
                        Do
                            .LastChar = .Text(.Pos)
                            .Pos = .Pos + 1
                            If .LastChar = 0 Then
                                Exit Function
                            End If
                        Loop While Not (.LastChar = 10 Or .LastChar = 13)    ' vbLf or vbCr
                    Case 42                               ' /*
                        lIdx = .Pos + 1
                        Do
                            .LastChar = .Text(lIdx)
                            lIdx = lIdx + 1
                            If .LastChar = 0 Then
                                .Error = "Unterminated comment at position " & .Pos
                                Exit Function
                            End If
                        Loop While Not (.LastChar = 42 And .Text(lIdx) = 47)    ' */
                        .LastChar = .Text(lIdx)
                        .Pos = lIdx + 1
                    Case Else
                        pvJsonGetChar = .LastChar
                        Exit Do
                    End Select
                Case Else
                    pvJsonGetChar = .LastChar
                    Exit Do
                End Select
            Loop
        End With
        Exit Function
    EH:
        RaiseError FUNC_NAME
    End Function
    
    
    
    Public Function JsonDump(vJson As Variant, Optional ByVal Level As Long, Optional ByVal Minimize As Boolean) As String
        Const FUNC_NAME As String = "JsonDump"
        Const STR_CODES As String = "\u0000|\u0001|\u0002|\u0003|\u0004|\u0005|\u0006|\u0007|\b|\t|\n|\u000B|\f|\r|\u000E|\u000F|\u0010|\u0011|\u0012|\u0013|\u0014|\u0015|\u0016|\u0017|\u0018|\u0019|\u001A|\u001B|\u001C|\u001D|\u001E|\u001F"
        Const Indent As Long = 4
        Static vTranscode As Variant
        Dim vKeys As Variant
        Dim vItems As Variant
        Dim lIdx As Long
        Dim lSize As Long
        Dim sCompound As String
        Dim sSpace As String
        Dim lAsc As Long
    
        On Error GoTo EH
        Select Case VarType(vJson)
        Case vbObject
            sCompound = IIf(vJson.CompareMode = 0, "[]", "{}")
            sSpace = IIf(Minimize, vbNullString, " ")
            If vJson.Count = 0 Then
                JsonDump = sCompound
            Else
                vKeys = vJson.keys
                vItems = vJson.Items
                For lIdx = 0 To vJson.Count - 1
                    vItems(lIdx) = JsonDump(vItems(lIdx), Level + 1, Minimize)
                    If vJson.CompareMode = 1 Then
                        vItems(lIdx) = JsonDump(vKeys(lIdx)) & ":" & sSpace & vItems(lIdx)
                    End If
                    lSize = lSize + Len(vItems(lIdx))
                Next
                If lSize > 100 And Not Minimize Then
                    JsonDump = Left$(sCompound, 1) & vbCrLf & _
                               Space$((Level + 1) * Indent) & Join(vItems, "," & vbCrLf & Space$((Level + 1) * Indent)) & vbCrLf & _
                               Space$(Level * Indent) & Right$(sCompound, 1)
                Else
                    JsonDump = Left$(sCompound, 1) & sSpace & Join(vItems, "," & sSpace) & sSpace & Right$(sCompound, 1)
                End If
            End If
        Case vbNull
            JsonDump = "Null"
        Case vbEmpty
            JsonDump = "Empty"
        Case vbString
            '--- one-time initialization of transcoding array
            If IsEmpty(vTranscode) Then
                vTranscode = Split(STR_CODES, "|")
            End If
            For lIdx = 1 To Len(vJson)
                lAsc = AscW(Mid$(vJson, lIdx, 1))
                If lAsc = 92 Or lAsc = 34 Then            '--- \ and "
                    JsonDump = JsonDump & "\" & Chr$(lAsc)
                ElseIf lAsc >= 32 And lAsc < 256 Then
                    JsonDump = JsonDump & Chr$(lAsc)
                ElseIf lAsc >= 0 And lAsc < 32 Then
                    JsonDump = JsonDump & vTranscode(lAsc)
                ElseIf Asc(Mid$(vJson, lIdx, 1)) <> 63 Then    '--- ?
                    JsonDump = JsonDump & Chr$(Asc(Mid$(vJson, lIdx, 1)))
                Else
                    JsonDump = JsonDump & "\u" & Right$("0000" & Hex(lAsc), 4)
                End If
            Next
            JsonDump = """" & JsonDump & """"
        Case Else
            JsonDump = vJson & ""
        End Select
        Exit Function
    EH:
        PrintError FUNC_NAME
        Resume Next
    End Function

  4. #4

    Thread Starter
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,044

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    I put a direct link to github in first post above.

    Try this link too: https://dl.unicontsoft.com/upload/mdJson.zip

    cheers,
    </wqw>

  5. #5
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    429

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    Json-SpeedTest(Time:ms)1.3M Size data
    why ChilkatJsonObject quickly than cConstructor(rc5json)?
    Json-AB :Json Load string(parsing)+stringify
    Action Chilkat Rc5Json Json2.js
    JsonLoad 20.09 48.37 25.53
    stringify 12.04 35.75 171.96
    Json-AB 32.13 84.12 197.48


    Code:
    Sub Test_ChilkatJsonObject()
    'Visual Basic 6.0 Load JSON Data at Path
    'https://www.example-code.com/vb6/json_load_to_path.asp
    
    Dim p As String
    p = "{""a"": 'sssss', ""b"": 2, ""c"": { ""x"": 1, ""y"": 2 } }"
    
    Dim json As New ChilkatJsonObject
    Dim success As Long
    success = json.Load(p)
    json.EmitCompact = 0
    Debug.Print json.Emit()
    
    Dim q As String
    q = "{""mm"": 11, ""nn"": 22}"
    
    Dim c As ChilkatJsonObject
    Set c = json.ObjectOf("c")
    success = c.Load(q)
    
    '  See that x and y are replaced with mm and nn.
    Debug.Print json.Emit()
    
    End Sub
    Attached Images Attached Images  
    Last edited by xiaoyao; May 25th, 2020 at 01:26 PM.

  6. #6
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,923

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    Quote Originally Posted by xiaoyao View Post
    Json-SpeedTest(Time:ms)1.3M Size data
    why ChilkatJsonObject quickly than cConstructor(rc5json)?
    Json-AB :Json Load string(parsing)+stringify
    Action Chilkat Rc5Json Json2.js
    JsonLoad 20.09 48.37 25.53
    stringify 12.04 35.75 171.96
    Json-AB 32.13 84.12 197.48
    There's basically two types of parsing-approaches:
    1) constructing the DOM(Object)-Hierarchy immediately (whilst parsing, with a lot of Object-instancing involved)
    2) delayed DOM(Object)-construction (after "pure-parsing" was done, members of the DOM-Tree are constructed "on access")

    The chilkat-parser is of Type #2 above, whilst wqwetos and my approach follow approach #1.

    So, to see which one is better in "real-world-scenarios", the timing will have to include "accessing DOM-Objects" -
    (e.g. when you want to import stuff from a parsed JSON-Object into a DB or something):

    Here is some Test-Code, which does such a real-world-scenario (accessing Data-Members of the parsed DOM).

    Code:
    Option Explicit
    
    Private sJSONinp As String
    
    Private Sub Form_Load()
      Dim D As cDownloads
      Set D = New_c.Downloads 'download a larger JSON-file into an inp-string first
      With D.Download("https://www.sba.gov/sites/default/files/data.json")
        If .WaitForCompletion(15) Then sJSONinp = New_c.Crypt.UTF8ToVBString(.GetContentData)
      End With
    End Sub
    
    Private Sub Form_Click()
      AutoRedraw = True: Cls: FontName = "Arial"
      
      '------------------------ RC5-JSON-stuff -----------------------
      New_c.Timing True
        Dim oJson As cCollection, oData As cCollection, Key$, Value, i&, j&, Tmp$
        Set oJson = New_c.JSONDecodeToCollection(sJSONinp)  'decode the JSON-string to Object
        Tmp = New_c.Timing
        
        For Each oData In oJson("dataset")
            For i = 0 To oData.Count - 1
                Key = oData.KeyByIndex(i)
                Select Case IsObject(oData.ItemByIndex(i))
                  Case True: Set Value = oData.ItemByIndex(i)
                  Case Else:     Value = oData.ItemByIndex(i)
                End Select
            Next
        Next
      Print "RC5-JSON-decode took:" & Tmp; vbLf; "RC5-JSON-decode + enum took:" & New_c.Timing; vbLf
      
     
      New_c.Timing True
        Dim oCKJson As ChilkatJsonObject, oCKArr As ChilkatJsonArray, oCKObj As ChilkatJsonObject
        Set oCKJson = New ChilkatJsonObject
            oCKJson.Load sJSONinp   'decode the JSON-string to Object
        Tmp = New_c.Timing
      
        Set oCKArr = oCKJson.ArrayOf("dataset")
        For i = 0 To oCKArr.Size - 1
            Set oCKObj = oCKArr.ObjectAt(i)
            For j = 0 To oCKObj.Size - 1
                Key = oCKObj.NameAt(j)
                Select Case oCKObj.TypeAt(j)
                  Case 3: Set Value = oCKObj.ObjectAt(j)
                  Case 4: Set Value = oCKObj.ArrayAt(j)
                  Case Else:  Value = oCKObj.StringAt(j)
                End Select
            Next
        Next
      Print "ChilKat-JSON-decode took:" & Tmp; vbLf; "ChilKat-JSON-decode + enum took:" & New_c.Timing; vbLf
    End Sub
    And here is the result (timings for "pure parsing", as well as the total time of "parsing + DOM-member-access"):


    So one has to be careful with "too synthetic performance-tests", which leave important parts of "real-world-usage" out.
    (in case of JSON, you parse a JSON-string for a reason... to get convenient access to the DOM-Objects and -Values).

    HTH

    Olaf

  7. #7
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    429

    Re: [VB6/VBA] JSON parsing to built-in VBA.Collections

    Thanks for your answers, I have thought about this question before, but I didn't pay attention this time. Some methods are really just loading for the first time, for example, just putting the JSON code into memory, and even without syntax check, you need to get the first level data, and then process them one by one, without even calculating the quantity first. If you give him a wrong JSON code, and then directly convert the object back to the JSON string, will he detect it, and what will it become in the end?

    There are too few users of VB6. You masters, top programmers are so rare. After a few years, you are all retired. It is estimated that no one can answer the questions. Sad about the future of VB6

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width