-
May 7th, 2021, 09:00 AM
#1
Thread Starter
PowerPoster
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|