在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