Results 1 to 10 of 10

Thread: best VB6 json parsing method(ScriptControl+Json2.js)

  1. #1

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    best VB6 json parsing method(ScriptControl+Json2.js)

    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

    Name:  0190-JSON算法测速结果PK2.png
Views: 241
Size:  46.7 KB
    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
    Code:
    Htm = "{""a"":""test"",""b"":""abc"",""arr1"":[{""c"":""aa"",""d"":""bb""},{""e"":""dd""}]}"
    
    Json1Code = "var JSON=function(){var m={'\b':'\\b','\t':'\\t','\n':'\\n','\f':'\\f','\r':'\\r','""':'\\""','\\':'\\\\'},s={'boolean':function(x){return String(x)},number:function(x){return isFinite(x)?String(x):'null'},string:function(x){if(/[""\\\x00-\x1f]/.test(x)){x=x.replace(/([\x00-\x1f\\""])/g,function(a,b){var c=m[b];if(c){return c}c=b.charCodeAt();return'\\u00'+Math.floor(c/16).toString(16)+(c%16).toString(16)})}return'""'+x+'""'},object:function(x){if(x){var a=[],b,f,i,l,v;if(x instanceof Array){a[0]='[';l=x.length;for(i=0;i<l;i+=1){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a[a.length]=v;b=true}}}a[a.length]=']'}else if(x instanceof Object){a[0]='{';for(i in x){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a.push(s.string(i),':',v);b=true}}}a[a.length]='}'}else{return}return a.join('')}return'null'}};return{"
    Json1Code = Json1Code & "copyright: '(c)2005 JSON.org',license:'http://www.crockford.com/JSON/license.html',stringify:function(v){var f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){return v}}return null},parse:function(text){try{return!(/[^,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t]/.test(text.replace(/""(\\.|[^""\\])*""/g,'')))&&eval('('+text+')')}catch(e){return false}}}}();"
    
    'json2_stringify.js
    Json1Code = "if(typeof JSON!=='object'){JSON={}}(function(){'use strict';var rx_one=/^[\],:{}\s]*$/;var rx_two=/\\(?:[""\\\/bfnrt]|u[0-9a-fA-F]{4})/g;var rx_three=/""[^""\\\n\r]*""|true|false|null|-?\d+(?:\.\d*)?(?:[eE][+\-]?\d+)?/g;var rx_four=/(?:^|:|,)(?:\s*\[)+/g;var rx_escapable=/[\\""\u0000-\u001f\u007f-\u009f\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g;var rx_dangerous=/[\u0000\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g;function f(n){return(n<10)?'0'+n:n}function this_value(){return this.valueOf()}if(typeof Date.prototype.toJSON!=='function'){Date.prototype.toJSON=function(){return isFinite(this.valueOf())?(this.getUTCFullYear()+'-'+f(this.getUTCMonth()+1)+'-'+f(this.getUTCDate())+'T'+f(this.getUTCHours())+':'+f(this.getUTCMinutes())+':'+f(this.getUTCSeconds())+'Z'):null};Boolean.prototype.toJSON=this_value;Number.prototype.toJSON=this_value;String.prototype.toJSON=this_value}" _
    & "var gap;var indent;var meta;var rep;function quote(string){rx_escapable.lastIndex=0;return rx_escapable.test(string)?'\""'+string.replace(rx_escapable,function(a){var c=meta[a];return typeof c==='string'?c:'\\u'+('0000'+a.charCodeAt(0).toString(16)).slice(-4)})+'\""':'\""'+string+'\""'}function str(key,holder){var i;var k;var v;var length;var mind=gap;var partial;var value=holder[key];if(value&&typeof value==='object'&&typeof value.toJSON==='function'){value=value.toJSON(key)}if(typeof rep==='function'){value=rep.call(holder,key,value)}switch(typeof value){case'string':return quote(value);case'number':return(isFinite(value))?String(value):'null';case'boolean':case'null':return String(value);case'object':if(!value){return'null'}gap+=indent;partial=[];if(Object.prototype.toString.apply(value)==='[object Array]'){length=value.length;for(i=0;i<length;i+=1){partial[i]=str(i,value)||'null'}v=partial.length===0?'[]':gap?('[\n'+gap+partial.join(',\n'+gap)+'\n'+mind+']'):'['+partial.join(',')+']'" _
    & ";gap=mind;return v} if(rep&&typeof rep==='object'){length=rep.length;for(i=0;i<length;i+=1){if(typeof rep[i]==='string'){k=rep[i];v=str(k,value);if(v){partial.push(quote(k)+((gap)?': ':':')+v)}}}}else{for(k in value){if(Object.prototype.hasOwnProperty.call(value,k)){v=str(k,value);if(v){partial.push(quote(k)+((gap)?': ':':')+v)}}}}v=partial.length===0?'{}':gap?'{\n'+gap+partial.join(',\n'+gap)+'\n'+mind+'}':'{'+partial.join(',')+'}';gap=mind;return v}}if(typeof JSON.stringify!=='function'){meta={'\b':'\\b','\t':'\\t','\n':'\\n','\f':'\\f','\r':'\\r','\""':'\\\""','\\':'\\\\'};JSON.stringify=function(value,replacer,space){var i;gap='';indent='';if(typeof space==='number'){for(i=0;i<space;i+=1){indent+=' '}}else if(typeof space==='string'){indent=space}rep=replacer;if(replacer&&typeof replacer!=='function'&&(typeof replacer!=='object'||typeof replacer.length!=='number')){throw new Error('JSON.stringify');}return str('',{'':value})}}}());"
    
    
    Dim Js As ScriptControl, JsonStr As String
    Set Js = New ScriptControl
    Js.Language = "Javascript"
    Js.AddCode "var JsonObj=" & Htm '字符转成json对象
    
    Js.AddCode Json1Code
    JsonStr = Js.Eval("JSON.stringify(JsonObj)")  'JSON对象转成“字符串”
    MsgBox "JsonStr=" & JsonStr
    cConstructor ,RC5-JSON(cConstructor vbRichClient5.DLL)
    Code:
    Htm = "{""a"":""中国人"",""b"":""abc"",""arr1"":[{""c"":""aa"",""d"":""bb""},{""e"":""dd""}]}"
    
    Dim New_c As New cConstructor
    Dim oJson As cCollection
    Dim sJSONout As String
    
    Set oJson = New_c.JSONDecodeToCollection(Htm)  'decode the JSON-string to Object
    sJSONout = oJson.SerializeToJSONString 'serialize the Object back into a JSON-string
    json.js(1.2k)
    json2.js (2.84k)
    json3.js(8k)

    i test json2.js is the best(used time :16 ms,JsonBag,38ms)
    ---------------------------
    In the case of large files, I eventually lost to the JS object
    After all, that is native JS, VB still has to parse

    50K JSON string to object, object to character
    Json1, time: 18.162882
    Json2, time: 16.407462
    Json3, time: 41.214192
    vbjson, time: 125.604048
    JsonConverter, time: 40.81495
    cDataJSON, time: 48.869498
    JsonBag, time: 38.097204
    ---------------------------

    50K large file, Json object to string
    Json1, time: 28.468988
    Json2, time: 17.008122
    Json3, time: 38.91001
    vbjson, time: 83.524864
    JsonConverter, time: 18.332476
    cDataJSON, time: 7.14318
    JsonBag, time: 21.876478
    Last edited by xiaoyao; May 25th, 2020 at 01:25 PM.

  2. #2

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    cDataJSON_En.cls(13kb)
    JsonBagV2.5.cls(42kb)
    Code:
    'JSON parsing class,Ver1.2
    Option Explicit
    
    Private Enum DATATYPE_JSON
        NullNull = 0
        ArrayType = 1
        ObjType = 2
        StringType = 3
        NumType = 4
    End Enum
    
    Private Enum Status '
        Status_Stop = 0 '
        Status_Start = 1
        Status_Add = 2
        Status_End = 3
    End Enum
    
    Public Active As New cDataJSON
    Public Parent As cDataJSON
    
    Public AttributeName As String
    Public AttributeValue As String
    
    Dim mAttributes As Collection
    Dim mArray As Collection
    Dim mDataType As Long
    
    Dim mKey As String
    Dim mTreeNameValue As String
    Dim mTreeSplit As String
    
    Public Sub ParseJson(ByVal JsonStringCode As String)
    'JSON code parsed into objects
    Dim i As Long
    Dim NameStatus As Long, ValueStatus As Long
    Dim tmpName As String, tmpValue As String
    Dim tmpJSON As cDataJSON
    Dim tmpMid As String
    Dim ValueType As Long
    Set tmpJSON = Me
    JsonStringCode = LTrim(JsonStringCode)
    For i = 1 To Len(JsonStringCode)
        tmpMid = Mid(JsonStringCode, i, 1)
        Select Case tmpMid
            Case vbCr, vbLf, vbTab
    '        Case vbTab, " ", "(", ")"
            Case "{"
                NameStatus = Status_Start
                ValueStatus = Status_Stop
                tmpJSON.DataType = ObjType
                Set tmpJSON = tmpJSON.AddObj
              
            Case "}"
                If NameStatus = Status_Add Or ValueStatus = Status_Add Then
                ElseIf ValueStatus > Status_Stop Then
                    tmpJSON.AttributeValue = tmpValue
                    tmpJSON.DataType = ValueType
                    tmpName = ""
                    tmpValue = ""
                    ValueType = 0
                    ValueStatus = Status_Stop
                    NameStatus = Status_Stop
                End If
                Set tmpJSON = tmpJSON.Parent
            Case Chr(34), Chr(39)
    
                If NameStatus = Status_Add Then
                    NameStatus = Status_End
                End If
                
                If ValueStatus = Status_Add Then
    '                tmpValue = tmpValue & tmpMid
                    ValueStatus = Status_End
                    ValueType = StringType
                End If
                
                If NameStatus = Status_Start Then
                    NameStatus = Status_Add
                    
                End If
                If ValueStatus = Status_Start Then
    '                tmpValue = tmpValue & tmpMid
                    ValueStatus = Status_Add
                End If
            Case "["
                    tmpJSON.DataType = ArrayType
                    Set tmpJSON = tmpJSON.AddObj
                    NameStatus = Status_Start
                    ValueStatus = Status_Start
            Case "]"
                If NameStatus = Status_Add Or ValueStatus = Status_Add Then
                ElseIf ValueStatus > Status_Stop Then
                    tmpJSON.AttributeValue = tmpValue
                    tmpJSON.DataType = ValueType
                    tmpName = ""
                    tmpValue = ""
                    ValueType = 0
                    ValueStatus = Status_Stop
                    NameStatus = Status_Stop
                End If
                Set tmpJSON = tmpJSON.Parent
            Case ":"
                If NameStatus = Status_Add Then
                    tmpName = tmpName & tmpMid
                End If
                If ValueStatus = Status_Add Then
                    tmpValue = tmpValue & tmpMid
                End If
                If NameStatus = Status_End Then
    '                Set tmpJSON = tmpJSON.AddObj
                    tmpJSON.AttributeName = tmpName
    
                    tmpName = ""
                    NameStatus = Status_Stop
    
                    tmpValue = ""
                    ValueType = 0
                    ValueStatus = Status_Start
                End If
    
            Case ","
    
                If NameStatus = Status_Add Or ValueStatus = Status_Add Then
                    If NameStatus = Status_Add Then tmpName = tmpName & tmpMid
                    If ValueStatus = Status_Add Then tmpValue = tmpValue & tmpMid
                Else
                    If ValueStatus > Status_Stop Then
                        tmpJSON.AttributeValue = tmpValue
                        tmpJSON.DataType = ValueType
                        tmpValue = ""
                        ValueType = 0
                        ValueStatus = Status_Start
                    End If
                    tmpName = ""
                    NameStatus = Status_Start
                    Set tmpJSON = tmpJSON.Parent
                    Set tmpJSON = tmpJSON.AddObj
                    
                End If
            
                
            Case Else
                If NameStatus = Status_Add Then
                    tmpName = tmpName & tmpMid
                End If
                If ValueStatus > Status_Stop Then
                    tmpValue = tmpValue & tmpMid
                End If
    
        End Select
    Next
    
    End Sub
    Public Function GetStrCode() As String
    'Get string of JSON object
    Dim tmpText As String
    Dim tmpJSON As cDataJSON
    Dim i As Long
    
    If Len(AttributeName) > 0 Then
        tmpText = tmpText & Chr(34) & AttributeName & Chr(34) & ":"
    End If
    
    If mDataType = ArrayType Then
        tmpText = tmpText & "["
        For Each tmpJSON In mArray
            tmpText = tmpText & tmpJSON.GetStrCode
            i = i + 1
            If i < mArray.Count Then tmpText = tmpText & ","
        Next
        tmpText = tmpText & "]"
    ElseIf mDataType = ObjType Then
        tmpText = tmpText & "{"
        For Each tmpJSON In mAttributes
            tmpText = tmpText & tmpJSON.GetStrCode
            i = i + 1
            If i < mAttributes.Count Then tmpText = tmpText & ","
        Next
        tmpText = tmpText & "}"
    Else
    '    tmpText = tmpText & AttributeValue
        If mDataType = StringType Then
            tmpText = tmpText & Chr(34) & AttributeValue & Chr(34)
        Else
            tmpText = tmpText & AttributeValue
        End If
    End If
        
    GetStrCode = tmpText
    End Function
    
    
    Public Property Let Key(NewValue As String)
        mKey = NewValue
    End Property
    Public Property Get Key() As String
    On Error GoTo QUIT
    If Len(mKey) = 0 Then
        If Len(Parent.Key) = 0 Then
            If Parent.DataType = ArrayType Then
                Key = Parent.Key & mTreeSplit & AttributeName
            ElseIf Parent.DataType = ObjType Then
                Key = Parent.Key & mTreeSplit & AttributeName
            End If
        Else
            Key = Parent.Key & mTreeSplit & AttributeName
        End If
    Else
        Key = mKey
    End If
    QUIT:
    End Property
    
    Public Function GetAttributeValue(AttributeName As String, Optional strSplit As String = "")
    Dim tmpJSON As cDataJSON
    
    Set tmpJSON = GetAttributeObject(AttributeName, strSplit)
    
    If Len(tmpJSON.AttributeValue) > 1 Then
        If Left(tmpJSON.AttributeValue, 1) = Chr(34) Then
            GetAttributeValue = Mid(tmpJSON.AttributeValue, 2, Len(tmpJSON.AttributeValue) - 2)
        Else
            GetAttributeValue = tmpJSON.AttributeValue
        End If
    Else
        GetAttributeValue = tmpJSON.AttributeValue
    End If
    
    End Function
    Public Function GetArrValue(Index As Long, Optional AttributeName As String = "", Optional strSplit As String = "")
    'Get array variables
    Dim tmpJSON As cDataJSON
    Set tmpJSON = GetAttributeObject(AttributeName, strSplit)
    Set tmpJSON = tmpJSON.ArrList(Index)
    GetArrValue = tmpJSON.AttributeValue
    End Function
    Public Function GetAttributeObject(AttributeName As String, Optional strSplit As String = "") As cDataJSON
    'Get the object, AttributeName is the attribute name
    Dim tmpJSON As cDataJSON
    Dim AttribList As cDataJSON
    Dim arrName() As String
    Dim i As Long
    
    If Len(strSplit) = 0 Then
        For Each tmpJSON In mAttributes
            If AttributeName = tmpJSON.AttributeName Then
                Set GetAttributeObject = tmpJSON
                Exit For
            End If
        Next
    Else
        arrName = Split(AttributeName, strSplit)
        For Each tmpJSON In mAttributes
            If arrName(0) = tmpJSON.AttributeName Then
                Set AttribList = tmpJSON
                Exit For
            End If
        Next
        For i = 1 To UBound(arrName)
            If Len(arrName(i)) > 0 Then
                For Each tmpJSON In AttribList.Attributes
                    If arrName(i) = tmpJSON.AttributeName Then
                        Set GetAttributeObject = tmpJSON
                        Set AttribList = tmpJSON
                        Exit For
                    End If
                Next
            End If
        Next
    
        Set GetAttributeObject = tmpJSON
    End If
    End Function
    
    Public Property Let DataType(newType As Long)
    mDataType = newType
    Select Case newType
        Case ArrayType
            Set mArray = New Collection
        Case ObjType
            Set mAttributes = New Collection
    End Select
    End Property
    Public Property Get DataType() As Long
    DataType = mDataType
    End Property
    Public Property Get Attributes() As Collection
    Set Attributes = mAttributes
    End Property
    Public Property Get ArrList() As Collection
    Set ArrList = mArray
    End Property
    
    Public Function AddObj(Optional Name As String = "") As cDataJSON
    'Add an object, judge the type of parent object according to
    'Return: object, (data type is not set))
        Dim tmpJSON As New cDataJSON
        If Len(Name) > 0 Then tmpJSON.AttributeName = Name
        If mDataType = ArrayType Then
            mArray.Add tmpJSON
        ElseIf mDataType = ObjType Then
            If Len(Name) > 0 Then
                mAttributes.Add tmpJSON, Name
            Else
                mAttributes.Add tmpJSON
            End If
        Else
            'Automatically set the parent data type to object
            mDataType = ObjType
            Set mAttributes = New Collection
            If Len(Name) > 0 Then
                mAttributes.Add tmpJSON, Name
            Else
                mAttributes.Add tmpJSON
            End If
        End If
        Set tmpJSON.Parent = Me
        Set Active = tmpJSON
        Set AddObj = tmpJSON
        Set tmpJSON = Nothing
    End Function
    
    Public Function AddAttrib(Optional Name As String = "", Optional Value As String = "", Optional IsString As Boolean = False) As cDataJSON
    'Add property, return new object
        Dim tmpJSON As cDataJSON
        Set tmpJSON = AddObj(Name)
    
        If IsString Then
    '        tmpJSON.AttributeValue = Chr(34) & Value & Chr(34)
            tmpJSON.AttributeValue = Value
            tmpJSON.DataType = StringType
        Else
            tmpJSON.AttributeValue = Value
            tmpJSON.DataType = NumType
        End If
        Set AddAttrib = tmpJSON
    End Function
    
    Public Function GetTreeStrNameValue() As String
    
    Dim tmpJSON As cDataJSON
    mTreeNameValue = ""
    If mDataType = ObjType Then
        For Each tmpJSON In mAttributes
            TreePathValue tmpJSON, tmpJSON.AttributeName
        Next
    ElseIf mDataType = ArrayType Then
        For Each tmpJSON In mArray
            TreePathValue tmpJSON, tmpJSON.AttributeName
        Next
    End If
    
    GetTreeStrNameValue = mTreeNameValue
    End Function
    
    Private Sub TreePathValue(eleJSON As cDataJSON, PathName As String)
    
    Dim tmpJSON As cDataJSON
    Dim tmpSubJSON As cDataJSON
    Dim j As Long
    If eleJSON.DataType = ObjType Then
        
        For Each tmpJSON In eleJSON.Attributes
    
            If tmpJSON.DataType = ObjType Or tmpJSON.DataType = ArrayType Then
                Call TreePathValue(tmpJSON, PathName & mTreeSplit & tmpJSON.AttributeName)
            Else
    '            tmpText = tmpJSON.AttributeName
    '            Debug.Print PathName & "_" & tmpJSON.AttributeName, "=", tmpJSON.AttributeValue
                mTreeNameValue = mTreeNameValue & PathName & mTreeSplit & tmpJSON.AttributeName & "=" & tmpJSON.AttributeValue & vbCrLf
            End If
    
        Next
    ElseIf eleJSON.DataType = ArrayType Then
    
        For Each tmpJSON In eleJSON.ArrList
            j = j + 1
            If tmpJSON.DataType = ObjType Or tmpJSON.DataType = ArrayType Then
                Call TreePathValue(tmpJSON, PathName & "[" & j & "]" & tmpJSON.AttributeName)
            Else
    '            tmpText = tmpJSON.AttributeName
    '            Debug.Print PathName & "_" & tmpJSON.AttributeName, "=", tmpJSON.AttributeValue
                If Len(tmpJSON.AttributeName) > 0 Then
                    mTreeNameValue = mTreeNameValue & PathName & "[" & j & "]" & mTreeSplit & tmpJSON.AttributeName & "=" & tmpJSON.AttributeValue & vbCrLf
                Else
                    mTreeNameValue = mTreeNameValue & PathName & "[" & j & "]=" & tmpJSON.AttributeValue & vbCrLf
                End If
            End If
    
        Next
    Else
        mTreeNameValue = mTreeNameValue & PathName & "=" & eleJSON.AttributeValue & vbCrLf
    End If
    End Sub
    
    
    Private Sub Class_Initialize()
    mTreeSplit = "\"
    End Sub

  3. #3

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    also can use v8.dll(by chrome),but The incoming parameters are converted to UTF8 encoding, and the extraction results must be transferred from UTF8 back to UNICODE again, and the operating efficiency is estimated to be greatly reduced。who can test?

  4. #4

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    JSON5 | JSON for Humans
    https://json5.org/
    node.js>>const JSON5 = require('json5')

  5. #5

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    https://gitee.com/eric_ds/jfire-codejson/tree/master/
    codejson is by far the most powerful json framework. The performance is 2.1 times fasterjson, 1.8 times jackson2, and 6.7 times gson.
    Performance analysis The reason why the performance of Jfire-codejson is so strong is that it uses a unique algorithm. Serialization Most of the traditional serialization frameworks, or relatively excellent serialization frameworks, use analysis of the content of the object, and then serialize the object through the method of reflection call method or reflection to get the attribute value. The biggest bottleneck of the framework generated by this idea is the performance consumption caused by reflection. Jfire-codejson uniquely uses the dynamic compilation of an output object for the serialized object. All the output objects call the serialized object's get method to get the attribute value. And when stitching the key name in json, because the code is dynamically compiled, the compiled code is known and written in advance, which reduces the step of obtaining the object attribute name. Make the serialization ability of Jfire-codejson approach the theoretical upper limit (this theoretical way of writing code for each object)

    Deserialization Deserialization first parses the json string. In this step, the framework has designed a single character reading method without backtracking. The general principle is to read each character in turn, if you encounter some special characters, such as {,},:, [,], etc. When these characters are encountered, jsonObject or jsonArray is generated for corresponding reading processing. Two stacks are used, one stack stores jsonKey and one stack stores the currently pending json object (jsonObject or jsonArray). In this way, the effect of sequential processing can be achieved during the processing. The parsing speed is very fast, and can achieve several times the performance of fastjson

  6. #6

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    cConstructor ,RC5-JSON(cConstructor vbRichClient5.DLL)
    This method runs the fastest, can you share the source code?
    thank you.
    Code:
    Json1Code = "var JSON=function(){var m={'\b':'\\b','\t':'\\t','\n':'\\n','\f':'\\f','\r':'\\r','""':'\\""','\\':'\\\\'},s={'boolean':function(x){return String(x)},number:function(x){return isFinite(x)?String(x):'null'},string:function(x){if(/[""\\\x00-\x1f]/.test(x)){x=x.replace(/([\x00-\x1f\\""])/g,function(a,b){var c=m[b];if(c){return c}c=b.charCodeAt();return'\\u00'+Math.floor(c/16).toString(16)+(c%16).toString(16)})}return'""'+x+'""'},object:function(x){if(x){var a=[],b,f,i,l,v;if(x instanceof Array){a[0]='[';l=x.length;for(i=0;i<l;i+=1){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a[a.length]=v;b=true}}}a[a.length]=']'}else if(x instanceof Object){a[0]='{';for(i in x){v=x[i];f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){if(b){a[a.length]=','}a.push(s.string(i),':',v);b=true}}}a[a.length]='}'}else{return}return a.join('')}return'null'}};return{"
    Json1Code = Json1Code & "copyright: '(c)2005 JSON.org',license:'http://www.crockford.com/JSON/license.html',stringify:function(v){var f=s[typeof v];if(f){v=f(v);if(typeof v=='string'){return v}}return null},parse:function(text){try{return!(/[^,:{}\[\]0-9.\-+Eaeflnr-u \n\r\t]/.test(text.replace(/""(\\.|[^""\\])*""/g,'')))&&eval('('+text+')')}catch(e){return false}}}}();"
    
    Htm = "{""a"":""3333"",""b"":""abc"",""arr1"":[{""c"":""aa"",""d"":""bb""},{""e"":""dd""}]}"
    
    Dim Js As ScriptControl, JsonStr As String
    Set Js = New ScriptControl
    Js.Language = "Javascript"
    Js.AddCode "var JsonObj=" & Htm 
    
    Js.AddCode Json1Code
    JsonStr = Js.Eval("JSON.stringify(JsonObj)")  
    
    MsgBox "JsonStr=" & JsonStr
    Jsontxt from:"https://www.sba.gov/sites/default/files/data.json" (1.3MB SIZE)
    ----------------
    StrToJsonObject+ObjectToSTR:

    Json1 ,Time(ms):193.73442
    Json2 ,Time(ms):173.22444
    Json3 ,Time(ms):1166.90108
    vbjson ,Time(ms):7827.51336
    JsonConverter,Time(ms):6587.33684
    cDataJSON ,Time(ms):1351.50216
    JsonBag ,Time(ms):2364.81656
    cConstructor ,Time(ms):74.62878

    ----------------
    JsonObjectToStr:

    Json1 ,Time(ms):172.668
    Json2 ,Time(ms):155.47996
    Json3 ,Time(ms):1149.53676
    vbjson ,Time(ms):7333.60354
    JsonConverter,Time(ms):6136.69794
    cDataJSON ,Time(ms):558.91872
    JsonBag ,Time(ms):1812.21622
    cConstructor ,Time(ms):32.69154

  7. #7

  8. #8
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,924

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    FWIW, here's wqwetos mdJSON.bas, integrated into my little performance-testsnippet:
    (which comes near with decoding-speed (Str-to-Obj), though the opposite direction (Obj-to-Str) has still room for further optimization)
    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
      
      '------------------------ RC5-JSON-stuff -----------------------
      New_c.Timing True
        Dim oJson As cCollection
        Set oJson = New_c.JSONDecodeToCollection(sJSONinp)  'decode the JSON-string to Object
      Print "JSON-decoding of " & Len(sJSONinp) & " Chars took:" & New_c.Timing
      
      New_c.Timing True
        Dim sJSONout As String
            sJSONout = oJson.SerializeToJSONString 'serialize the Object back into a JSON-string
      Print "JSON-encoding to " & Len(sJSONout) & " Chars took:" & New_c.Timing
      
      
      '------------------------ mdJSON.bas (wqweto) -----------------------
      'https://github.com/wqweto/UcsFiscalPrinters/blob/master/src/Shared/mdJson.bas
      New_c.Timing True
        Dim oJCol As VBA.Collection
        Set oJCol = JsonParseObject(sJSONinp) 'decode the JSON-string to Object
      Print "JsonParseObject from " & Len(sJSONinp) & " Chars took:" & New_c.Timing
      
      sJSONout = vbNullString 'cleanup the target-buffer first
      New_c.Timing True
            sJSONout = JsonDump(oJCol)
      Print "JsonDump to " & Len(sJSONout) & " Chars took:" & New_c.Timing
    End Sub
    One needs to compile natively, for the comparisons to be of use...

    Olaf

  9. #9
    PowerPoster wqweto's Avatar
    Join Date
    May 2011
    Posts
    2,100

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    Yes, parsing is within reach of RC5 while JsonDump is slow as it produces human-readable output and even for the Minimize:=True case to be faster it will need a solid byte-array based StringBuilder.

    Trying to beat RC5 makes no sense and would be too much work as RC5 already has solid primitives (Collections, StringBuilders) well implemented and tested.

    cheers,
    </wqw>

  10. #10

    Thread Starter
    Hyperactive Member
    Join Date
    Jan 2020
    Posts
    431

    Re: best VB6 json parsing method(ScriptControl+Json2.js)

    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

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