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
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 SubCode:
'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