Results 1 to 1 of 1

Thread: XiaoYao Json Class by ScriptControl 【very interesting】

  1. #1

    Thread Starter
    Taking a Break
    Join Date
    Jan 2020
    Posts
    1,340

    XiaoYao Json Class by ScriptControl 【very interesting】

    There are still many problems with this module, which are limited to research and use, and commercial errors may occur.
    For example, adding sub-arrays, subordinates, etc., is really not easy to implement


    json2.js(2017-6-12),from https://github.com/douglascrockford/...aster/json2.js
    Code:
    Sub XiaoJsonTest()
    Dim Json As XiaoJson
    Set Json = New XiaoJson
    
    
    Dim Htm As String
    Htm = "{""a"":""AAABBB"",""b"":""abc"",""arr1"":[{""c"":""aa"",""d"":""bb""},{""e"":""dd""}]}"
    Json.SetJsonObjectStr Htm
    '================
    MsgBox Json.GetValue("a")
    Json.SetValue "a", "CCC" & vbCrLf & "22"
    MsgBox Json.GetValue("a")
    '=============
    Dim S As String
    S = Json.GetJsonObjectStrFormat
    Clipboard.Clear
    Clipboard.SetText S
    MsgBox S
    Json.SetValue "a", 666
    MsgBox Json.GetJsonObjectStr("arr1")
    MsgBox Json.GetJsonObjectStrFormat("arr1")
    MsgBox Json.GetValue("a")
    
    MsgBox Json.GetValue("a") & ",typename=" & TypeName(Json.GetValue("a"))
    Dim SingleV As Currency
    SingleV = 3.14
    Json.SetValue "a", SingleV
    
    MsgBox Json.GetValue("a") & ",typename=" & TypeName(Json.GetValue("a"))
    
    MsgBox Json.GetJsonObjectStr
    End Sub
    Code:
      'code in class (XiaoJson.cls)
     'add Reference= msscript.ocx#Microsoft Script Control 1.0
     'Dim JsLib As New ScriptControl
    Option Explicit
    
    Dim JsLib As Object 'Method 2
    Private Sub Class_Initialize()
        CreateNew
    End Sub
    Sub CreateNew() 'if code in bas file,run CreateNew First
    If Not JsLib Is Nothing Then Set JsLib = Nothing
    'Set JsLib = New ScriptControl
    Set JsLib = CreateObject("ScriptControl")  'Method 2
    JsLib.Language = "Javascript"
    Dim JsCode As String
    Dim Htm As String
    
    ''JsCode = "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{"
    ''JsCode = JsCode & "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}}}}();"
    
    JsCode = "if(typeof JSON!==""object""){JSON={}}(function(){""use strict"";var g=/^[\],:{}\s]*$/;var h=/\\(?:[""\\\/bfnrt]|u[0-9a-fA-F]{4})/g;var l=/""[^""\\\n\r]*""|true|false|null|-?\d+(?:\.\d*)?(?:[eE][+\-]?\d+)?/g;var m=/(?:^|:|,)(?:\s*\[)+/g;var o=/[\\""\u0000-\u001f\u007f-\u009f\u00ad\u0600-\u0604\u070f\u17b4\u17b5\u200c-\u200f\u2028-\u202f\u2060-\u206f\ufeff\ufff0-\uffff]/g;var p=/[\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"
    JsCode = JsCode & "=this_value;Number.prototype.toJSON=this_value;String.prototype.toJSON=this_value}var q;var r;var s;var t;function quote(b){o.lastIndex=0;return o.test(b)?""\""""+b.replace(o,function(a){var c=s[a];return typeof c===""string""?c:""\\u""+(""0000""+a.charCodeAt(0).toString(16)).slice(-4)})+""\"""":""\""""+b+""\""""}function str(a,b){var i;var k;var v;var c;var d=q;var e;var f=b[a];if(f&&typeof f===""object""&&typeof f.toJSON===""function""){f=f.toJSON(a)}if(typeof t===""function""){f=t.call(b,a,f)}switch(typeof f){case""string"":return quote(f);case""number"":return(isFinite(f))?String(f):""null"";case""boolean"":case""null"":return String(f);case""object"":if(!f){return""null""}q+=r;e=[];if(Object.prototype.toString.apply(f)===""[object Array]""){c=f.length;for(i=0;i<c;i+=1){e[i]=str(i,f)||""null""}v=e.length===0?""[]"":q?(""[\n""+q+e.join("",\n""+q)+""\n""+d+""]""):""[""+e.join("","")+""]"";q=d;return v}if(t&&typeof t===""object"")"
    JsCode = JsCode & "{c=t.length;for(i=0;i<c;i+=1){if(typeof t[i]===""string""){k=t[i];v=str(k,f);if(v){e.push(quote(k)+((q)?"": "":"":"")+v)}}}}else{for(k in f){if(Object.prototype.hasOwnProperty.call(f,k)){v=str(k,f);if(v){e.push(quote(k)+((q)?"": "":"":"")+v)}}}}v=e.length===0?""{}"":q?""{\n""+q+e.join("",\n""+q)+""\n""+d+""}"":""{""+e.join("","")+""}"";q=d;return v}}if(typeof JSON.stringify!==""function""){s={""\b"":""\\b"",""\t"":""\\t"",""\n"":""\\n"",""\f"":""\\f"",""\r"":""\\r"",""\"""":""\\\"""",""\\"":""\\\\""};JSON.stringify=function(a,b,c){var i;q="""";r="""";if(typeof c===""number""){for(i=0;i<c;i+=1){r+="" ""}}else if(typeof c===""string""){r=c}t=b;if(b&&typeof b!==""function""&&(typeof b!==""object""||typeof b.length!==""number"")){throw new Error(""JSON.stringify"");}return str("""",{"""":a})}}if(typeof JSON.parse!==""function""){JSON.parse=function(d,e){var j;function walk(a,b){var k;var v;var c=a[b];if(c&&typeof c===""object""){for(k in c)"
    JsCode = JsCode & "{if(Object.prototype.hasOwnProperty.call(c,k)){v=walk(c,k);if(v!==undefined){c[k]=v}else{delete c[k]}}}}return e.call(a,b,c)}d=String(d);p.lastIndex=0;if(p.test(d)){d=d.replace(p,function(a){return(""\\u""+(""0000""+a.charCodeAt(0).toString(16)).slice(-4))})}if(g.test(d.replace(h,""@"").replace(l,""]"").replace(m,""""))){j=eval(""(""+d+"")"");return(typeof e===""function"")?walk({"""":j},""""):j}throw new SyntaxError(""JSON.parse"");}}}());"
    
    '==============
    JsCode = JsCode & "var JsonObj={};function Js_SetJsonValue(Key,Str){JsonObj[Key]=Str;}" & vbCrLf
    
    JsLib.AddCode JsCode
    End Sub
    
    Function SetValue(JsonKey As String, NewVal, Optional IsString As Boolean, Optional ErrInfo As String) As Boolean
        On Error GoTo DoErr
        ErrInfo = ""
        Call JsLib.Run("Js_SetJsonValue", JsonKey, IIf(IsString, "'" & NewVal & "'", NewVal))
        SetValue = True
        Exit Function
    DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
    End Function
    
    Function GetValue(JsonKey As String, Optional ErrInfo As String)
        On Error GoTo DoErr
        ErrInfo = ""
        GetValue = JsLib.Eval("JsonObj." & JsonKey)
        Exit Function
    DoErr:
        ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
    End Function
    
    
    Function SetNumber(JsonKey As String, NewVal, Optional ErrInfo As String) As Boolean
     SetNumber = SetValue(JsonKey, NewVal, False, ErrInfo)
    End Function
    Function SetJsonObjectStr(JsonCode As String, Optional ErrInfo As String) As Boolean
        On Error GoTo DoErr
        ErrInfo = ""
        JsLib.Eval ("var JsonObj=" & JsonCode)
        SetJsonObjectStr = True
        Exit Function
    DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
    End Function
    Function GetJsonObjectStr(Optional JsonKey As String, Optional AddDot As Boolean = True, Optional ErrInfo As String) As String
        On Error GoTo DoErr
        ErrInfo = ""
        GetJsonObjectStr = JsLib.Eval("JSON.stringify(JsonObj" & IIf(JsonKey <> "", IIf(AddDot, ".", "") & JsonKey, "") & ")")
        Exit Function
    DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
    End Function
    
    Function GetJsonObjectStrFormat(Optional JsonKey As String, Optional AddDot As Boolean = True, Optional ErrInfo As String) As String
        On Error GoTo DoErr
        ErrInfo = ""
        GetJsonObjectStrFormat = JsLib.Eval("JSON.stringify(JsonObj" & IIf(JsonKey <> "", IIf(AddDot, ".", "") & JsonKey, "") & ", null, '\t')")
        GetJsonObjectStrFormat = Replace(GetJsonObjectStrFormat, vbLf, vbCrLf)
        Exit Function
    DoErr:    ErrInfo = "ErrNumber:" & Err.Number & ",Description:" & Err.Description
    End Function
    Last edited by xiaoyao; May 7th, 2021 at 09:59 AM.

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