在VBA中
新建类 XiaoYaoJson.cls ,代码:
Option Explicit
'逍遥纯源码:Json组件模块,支持32位,64位VBA,VB6,修改一下也支持VBS
'ver 2.0
'======================
'本组件可以免费商用,版权所有,请保留作者信息
'QQ: 527524938 设计制作 逍遥软件
'http://www.xiaoyaosoft.com
'http://www.taobaosoft.com
'
'新版本可以在线查找,升级
'网页爬虫,VBA自动化 程序优化提速,BUG修复
'======================
'Json.ItemEx("key")="{}" '添加一个Json子对象
'Json.ItemEx("key")="{""a"":""s1""}" '添加一个Json子对象和数据
'Json.ItemEx("key") = "[3,4]" '添加数组
'stringify(ItemName As String) As String '返回一行的JSON字符串
'Dim Doc As HTMLDocument, HtmlWindowA As HTMLWindow2 '引用Microsoft Html object的用这个,速度更快
Private Doc As Object, HtmlWindowA As Object
Public JsonObj As Object
Public Property Get Item(ItemName As String) As Variant
Item = HtmlWindowA.eval("JsonObj." & ItemName)
End Property
Public Property Let Item(ItemName As String, ByVal vNewValue As Variant)
If TypeName(vNewValue) = "String" Then vNewValue = """" & vNewValue & """"
HtmlWindowA.execScript "JsonObj." & ItemName & "=" & vNewValue
End Property
Function KeysCount(KeyName As String) As Long
'On Error Resume Next
HtmlWindowA.execScript "var keys = Object.keys(" & FullKey(KeyName) & ");var KeysCount=keys.length;"
KeysCount = Doc.Script.KeysCount
' KeysCount = HtmlWindowA.eval("var keys = Object.keys(" & FullKey(KeyName) & "); keys.length;")
End Function
Function IsType(Key As String, ByVal TypeName1 As String) As Boolean '是否对象
'TypeName1可选值[String,Array,Object,等等]
'Object.prototype.toString.call( jsonObj ) === '[object Array]'
TypeName1 = LCase(TypeName1)
Select Case TypeName1 '常见js类型
Case "object": TypeName1 = "Object"
Case "string": TypeName1 = "String"
Case "array": TypeName1 = "Array"
Case "long": TypeName1 = "Number"
Case "number": TypeName1 = "Number"
End Select
IsType = HtmlWindowA.eval("Object.prototype.toString.call(" & FullKey(Key) & ") === '[object " & TypeName1 & "]'")
Exit Function
End Function
Function TypeName2(Key As String) As String '是否对象
'Object.prototype.toString.call( jsonObj ) === '[object Array]'
On Error Resume Next
Dim TypeNameJsA As String
TypeNameJsA = HtmlWindowA.eval("Object.prototype.toString.call(" & FullKey(Key) & ")")
If Left(TypeNameJsA, 8) = "[object " Then
TypeName2 = Mid(TypeNameJsA, 9, Len(TypeNameJsA) - 9)
End If
End Function
Function TypeNameJs(Key As String) As String '是否对象
'TypeName1可选值[String,Array,Object,等等]
'Object.prototype.toString.call( jsonObj ) === '[object Array]'
On Error Resume Next
TypeNameJs = HtmlWindowA.eval("Object.prototype.toString.call(" & FullKey(Key) & ")")
End Function
Function GetAllKeys(Optional KeyName As String) As String()
Dim KeysCountA As Long, KeyNameArr() As String
KeysCountA = KeysCount(KeyName)
If KeysCountA > 0 Then
Dim AllKeys As String
AllKeys = HtmlWindowA.eval("keys.join('@@--')")
KeyNameArr = Split(AllKeys, "@@--")
Else
ReDim KeyNameArr(-1 To -1)
End If
GetAllKeys = KeyNameArr
End Function
Function GetAllKeys2(Optional KeyName As String) As String()
Dim KeysCountA As Long, KeyNameArr() As String
KeysCountA = KeysCount(KeyName)
If KeysCountA > 0 Then
ReDim KeyNameArr(KeysCountA - 1) As String
Dim I As Long
For I = 0 To KeysCountA - 1
KeyNameArr(I) = HtmlWindowA.eval("keys[" & I & "]")
Next
Else
ReDim KeyNameArr(-1 To -1)
End If
GetAllKeys2 = KeyNameArr
End Function
Public Property Let ItemEx(ItemName As String, ByVal vNewValue As String)
On Error Resume Next '添加数组或对象的用这个方法:vNewValue="[1,2]" '数组 vNewValue="{'a':11,'b':2}"
HtmlWindowA.execScript "JsonObj." & ItemName & "=" & vNewValue
If ERR.Number <> 0 Then Debug.Print "ItemEx err:" & ERR.Description
End Property
Public Property Get stringify(Optional ItemName As String) As String '返回一行的JSON字符串
stringify = HtmlWindowA.eval("JSON.stringify(" & "JsonObj" & IIf(ItemName = "", "", "." & ItemName) & ")")
End Property
Private Function FullKey(Key As String) As String
'KEY里面有[的请输入完整的路径,JsonObj.开头
'只输入UserName,JS本身操作是需要JsonObj.UserName
'如果传入[Key1],含有字符"[" ,返回JsonObj[Key1]
FullKey = IIf(Key <> "", "JsonObj" & IIf(Left(Key, 1) = "[", "", ".") & Key, "JsonObj")
End Function
Private Sub Class_Initialize()
Dim js As String, JsCode As String
Set Doc = CreateObject("htmlfile")
Set HtmlWindowA = Doc.parentWindow
'JSON 2.0.js
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"");}}}());"
js = JsCode & vbCrLf & "var JsonObj ={} ;function SetJsonStr(JsonStr){JsonObj=JSON.parse(JsonStr);};"
Dim Sz() As String
ReDim Sz(6) 'ReDim Sz(7)
Sz(0) = "function JsonFormat(JsonObj_or_Str) {"
Sz(1) = " if (JsonObj_or_Str=="""") {"
Sz(2) = " return JSON.stringify(JsonObj, null, 2);"
Sz(3) = " }"
Sz(4) = " else if(typeof JsonObj_or_Str === 'object'){return JSON.stringify(JsonObj_or_Str, null, 2);}"
Sz(5) = " else{return JSON.stringify(eval(""JsonObj.""+JsonObj_or_Str), null, 2);}"
Sz(6) = " }"
ReDim Preserve Sz(19)
Sz(7) = "if (!Object.keys) {"
Sz(8) = " Object.keys = (function() {"
Sz(9) = " return function(obj) {"
Sz(10) = " var keys = [];"
Sz(11) = " for (var key in obj) {"
Sz(12) = " if (obj.hasOwnProperty(key)) {"
Sz(13) = " keys.push(key);"
Sz(14) = " }"
Sz(15) = " }"
Sz(16) = " return keys;"
Sz(17) = " };"
Sz(18) = " })();"
Sz(19) = "}"
js = js & vbCrLf & Join(Sz, vbCrLf)
HtmlWindowA.execScript js, "JScript"
' ReDim Sz(6)
' Sz(0) = "function keysSupport(){"
' Sz(1) = "if (typeof Object.keys === 'function') {"
' Sz(2) = " return '支持 Object.keys';"
' Sz(3) = "} else {"
' Sz(4) = " return '不支持keys,需引入 Polyfill';"
' Sz(5) = "}"
' Sz(6) = "}"
'
' js = Join(Sz, vbCrLf)
' HtmlWindowA.execScript js, "JScript"
'Debug.Print "keysSupport=" & Json.eval("keysSupport()")
Set JsonObj = HtmlWindowA.JsonObj
Exit Sub
ERR:
MsgBox "ERR:" & ERR.Number & "," & ERR.Description
End Sub
Public Property Get JsonStr() As String
JsonStr = Doc.Script.JsonFormat("")
End Property
Public Property Let JsonStr(ByVal vNewValue As String)
On Error Resume Next
Doc.Script.SetJsonStr vNewValue
Set JsonObj = HtmlWindowA.JsonObj
vNewValue = ERR.Number = 0
End Property
Public Function SetJsonStr(JsonStr As String) As Boolean
'给Json设置一整段字符串
On Error Resume Next
Doc.Script.SetJsonStr JsonStr
Set JsonObj = HtmlWindowA.JsonObj
SetJsonStr = ERR.Number = 0
End Function
Public Function GetJsonStr(Optional Key As String) As String
'Call HtmlWindowA.SetJsonStr(JsonStr)
'返回JSON字符串
GetJsonStr = Doc.Script.JsonFormat(Key)
End Function
Public Function GetJsonStrObject(obj1 As Object) As String
GetJsonStrObject = Doc.Script.JsonFormat(obj1)
End Function
Function eval(code As String) As String
On Error GoTo ERR
eval = HtmlWindowA.eval(code)
Exit Function
ERR:
eval = "Err:" & ERR.Number & ",信息:" & ERR.Description
End Function
Public Property Get Arraylength(ItemName As String) As Long '取数组成员数
''Arraylength=取数组成员数
Item = HtmlWindowA.eval("JsonObj." & ItemName & ".length")
End Property
Function RemoveArrayByIndex(ItemName As String, ByVal IndexA As Long) As Boolean
On Error Resume Next '删除数组中第N个值(INDEX=N-1)
'good
HtmlWindowA.execScript "JsonObj." & ItemName & ".splice(" & IndexA & ", 1)"
RemoveArrayByIndex = True
Exit Function
ERR:
Debug.Print "err:RemoveArrayByIndex:" & ERR.Description
End Function
'
Public Sub ArrayAdd(ItemName As String, ByVal vNewValue As Variant, Optional AutoSetType As Boolean = True)
'数组添加一个值
'AutoSetType=false,可以添加对象,就不会自动添加前号双引号
If AutoSetType Then
If TypeName(vNewValue) = "String" Then vNewValue = """" & vNewValue & """"
End If
Call HtmlWindowA.execScript("JsonObj." & ItemName & ".push(" & vNewValue & ")")
End Sub
新建Excel文件 XiaoYaoJson_vba_json(x86,x64).xlsm ,新建 模块1.bas 代码:
Option Explicit
'逍遥纯源码:Json组件模块,支持32位,64位VBA,VB6,修改一下也支持VBS
'ver 2.0
'======================
'本组件可以免费商用,版权所有,请保留作者信息
'QQ: 527524938 设计制作 逍遥软件
'
'新版本可以在线查找,升级
'网页爬虫,VBA自动化 程序优化提速,BUG修复
'======================
Sub ExcelJson测试()
Dim Json As New XiaoYaoJson
Dim jsonString As String
jsonString = "{ ""Name"": ""John"", ""age"": 30, ""city"": ""New York"" ,""obj1"":{""a"":3,""b"":""s2""} }"
If Not Json.SetJsonStr(jsonString) Then '设置JSON字符串
MsgBox "json数据格式有误"
Exit Sub
End If
Debug.Print "GetAllKeys=" & Join(Json.GetAllKeys, ",") '取回所有键名
Debug.Print "GetAllKeys=" & Join(Json.GetAllKeys("obj1"), ",")
Debug.Print "TypeNameJs=" & Json.TypeNameJs("obj1") '取某个键的数据类型
Debug.Print "Name TypeNameJs=" & Json.TypeNameJs("Name")
Debug.Print "TypeNameJs=" & Json.IsType("obj1", "Object") '检测是字符,数字还是数组
Debug.Print "TypeNameJs(age)=" & Json.IsType("age", "number")
Debug.Print "age TypeNameJs=" & Json.TypeNameJs("age")
Debug.Print "Name=" & Json.Item("Name") '取值
Json.Item("age") = 40 '改值
Json("age") = 41 '可以不需要用Item
Debug.Print "KeysCount=" & Json.KeysCount("")
Debug.Print "年纪=" & Json("age")
Json.ItemEx("Arr1") = "[3,4,5]" '添加一个元素:数组类型
Debug.Print "TypeName2('Name',Arr1,age,obj1)=" & Json.TypeName2("Name") & "," & Json.TypeName2("age") & "," & Json.TypeName2("Arr1") & "," & Json.TypeName2("obj1")
Debug.Print "GetAllKeys=" & Join(Json.GetAllKeys("Arr1"), ",")
Debug.Print "读取Json数组的值:" & Json.Item("Arr1[0]")
Debug.Print "数组成员数:" & Json.Item("Arr1.length")
Debug.Print Json.eval("JsonObj.age") 'eval方式支持更高级操作
Debug.Print Json.GetJsonStr("")
Call Json.ArrayRemoveIndex("Arr1", 1) '删除数组中第2个值
Debug.Print "GetJsonStrObject=" & Json.GetJsonStrObject(Json.JsonObj.Arr1)
Call Json.ArrayAddItem("Arr1", "abcd") '插入数组一个值
Debug.Print "Arr1[2]=" & Json.Item("Arr1[2]")
Json.Item("Arr1[2]") = "3344"
Debug.Print "Arr1[2]=" & Json.Item("Arr1[2]")
Debug.Print "GetJsonStrObject=" & Json.GetJsonStrObject(Json.JsonObj.Arr1)
Dim obj1 '防止IDE首字母大写
Debug.Print "GetJsonStrObject=" & Json.GetJsonStrObject(Json.JsonObj.obj1)
Debug.Print "stringify=" & Json.stringify("obj1")
Debug.Print "stringify=" & Json.stringify()
End Sub
新建 模块2.bas 代码:
Option Explicit
Sub TEST2()
Dim Json As New XiaoYaoJson
Dim jsonString As String
jsonString = "{ ""Name"": ""John"", ""age"": 30, ""city"": ""New York"" ,""obj1"":{""a"":3,""b"":""s2""} }"
'Json.SetJsonStr jsonString
Json.parse jsonString
'Json.JsonStr = jsonString
'MsgBox Json.JsonStr
Debug.Print Json("Name")
Json.TempJsValue("temp1") = "abcd"
Debug.Print Json.TempJsValue("temp1")
Debug.Print Json.Script.temp1
Json("Name") = "逍遥"
Debug.Print Json("Name")
Debug.Print Json.stringify
Json.AddArray "arr3"
Json.ArrayAddItem "arr3", "v1"
Json.ArrayAddItem "arr4", "v2"
Debug.Print Json.stringify("", True)
Json.AddArray "arr1"
Json.ArrayAddItem "arr1", 123
Json.Delete "city"
'Json.RunJs "JsonObj.订单号='dd3344'"
Json.RunJs "JsonObj.订单号=""dd3344"""
'Json.Add "['订单号']", "dd344"
'MsgBox Json.eval("'订单号2' in JsonObj")
'MsgBox Json.eval("'b' in JsonObj.obj1")
'MsgBox Json.HaveKey("b", "obj1")
'MsgBox Json.eval("'age' in JsonObj")
Json.Add "ddh", "dd3344"
'Json.Add "订单号2", "33,44" ' "dd33--" & vbCrLf & "44"
Json.Add "订单号2", "dd33--" & vbCrLf & "44"
Json("ddh") = "dd3344"
Json.Add "arr2", Array(33, 44, "ss")
Debug.Print Json("订单号2")
Debug.Print Json.stringify("", True)
Debug.Print "数组,第3元素是:" & Json.ArrayItem("arr2", 2)
Json.ArrayItem("arr2", 2) = 999
Debug.Print "数组,第3元素是:" & Json.ArrayItem("arr2", 2)
Debug.Print Json.stringify(, True)
Json("aa") = "dd3344"
End Sub