VBA 的JSON解析代码

于 2025-03-22 19:54:22 发布
阅读量536 收藏 9
点赞数 3
分类专栏： 开发技巧 文章标签： json VBA
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.youkuaiyun.com/m0_47587308/article/details/146445312
版权

偶然看到了一段JSON解析代码，能在VBA/VB6运行。分析了一下，是利用的webbroswer处理，感觉有点奇葩。

分析

1. 初始化

在 Class_Initialize 过程里，借助 CreateObject("htmlfile") 构建一个 HTML 文档对象，并且运用 execScript 方法将 JSON 解析和序列化的 JavaScript 代码注入其中。初始化完成后，会生成一个空的 JSON 对象 JsonObj。

2. 属性和方法

属性
  • Item：用来获取或设置 JSON 对象里指定键的值。
  • ItemEx：可用于添加数组或者子 JSON 对象。
  • stringify：把 JSON 对象转换为 JSON 字符串，并且可以选择是否添加换行符。
  • JsonStr：获取或者设置整个 JSON 对象的字符串表示。
方法
  • KeysCount：返回指定键下的子键数量。
  • AddObject：在指定键下添加一个新的 JSON 子对象。
  • AddArray：在指定键下添加一个新的数组。
  • Delete：删除指定键及其对应的数据。
  • IsType：判断指定键的数据类型是否为特定类型（如 Object、Array、String 等）。
  • TypeName2：返回指定键的数据类型名称。
  • TypeNameJs：返回指定键的数据类型的 JavaScript 表示。
  • GetAllKeys 和 GetAllKeys2：返回指定键下的所有子键名称。
  • parse：将 JSON 字符串解析为 JSON 对象。
  • SetJsonStr：为 JSON 对象设置一整段 JSON 字符串。
  • GetJsonStr：返回指定键的 JSON 字符串表示。
  • GetJsonStrObject：返回指定对象的 JSON 字符串表示。
  • eval：执行 JavaScript 代码并返回结果。
  • Arraylength：获取指定数组的长度。
  • RemoveArrayByIndex：删除数组中指定索引的元素。
  • ArrayAdd：往数组中添加一个新元素。

3. 示例用法

下面是一些可能的使用示例：

Sub TestXiaoYaoJson()
    Dim Json As New XiaoYaoJson
    
    ' 设置 JSON 对象的值
    Json.Item("name") = "John"
    Json.Item("age") = 30
    
    ' 添加一个子 JSON 对象
    Json.ItemEx("address") = "{""city"":""New York"",""zip"":""10001""}"
    
    ' 添加一个数组
    Json.ItemEx("hobbies") = "[ ""reading"", ""swimming"", ""running"" ]"
    
    ' 获取 JSON 字符串
    Dim jsonStr As String
    jsonStr = Json.stringify
    
    Debug.Print jsonStr
End Sub

4. 注意事项

  • 此组件支持 32 位和 64 位的 VBA 以及 VB6，经过修改后也可在 VBS 中使用。
  • 组件能够免费商用，但需要保留作者信息。
  • 代码中运用了 HTML 文档对象的 execScript 方法来执行 JavaScript 代码，以此实现 JSON 的解析和序列化。

代码如下

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "HtmlJson"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Doc As Object
Private HtmlWindowA As Object
Public JsonObj As Object

' 获取或设置 JSON 对象中指定键的值
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
    HtmlWindowA.execScript "var keys = Object.keys(" & FullKey(KeyName) & ");var KeysCount=keys.length;"
    KeysCount = Doc.Script.KeysCount
End Function

' 添加一个子 json 对象，方便添加新值
Function AddObject(KeyName As String) As Boolean
    On Error Resume Next
    HtmlWindowA.execScript FullKey(KeyName) & "={}"
    AddObject = Err.Number = 0
End Function

' 添加一个数组
Function AddArray(KeyName As String) As Boolean
    On Error Resume Next
    HtmlWindowA.execScript FullKey(KeyName) & "=[]"
    AddArray = Err.Number = 0
End Function

' 删除一个键和数据
Function Delete(KeyName As String) As Boolean
    On Error Resume Next
    If KeyName = "" Then Exit Function
    HtmlWindowA.execScript "delete " & FullKey(KeyName)
    Delete = Err.Number = 0
End Function

' 判断指定键的数据类型是否为特定类型
Function IsType(Key As String, ByVal TypeName1 As String) As Boolean
    TypeName1 = LCase(TypeName1)
    Select Case TypeName1
        Case "object": TypeName1 = "Object"
        Case "string": TypeName1 = "String"
        Case "array": TypeName1 = "Array"
        Case "long", "number": TypeName1 = "Number"
    End Select
    IsType = HtmlWindowA.eval("Object.prototype.toString.call(" & FullKey(Key) & ") === '[object " & TypeName1 & "]'")
End Function

' 检测数据类型
Function TypeName2(Key As String) As String
    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

' 返回指定键的数据类型的 JavaScript 表示
Function TypeNameJs(Key As String) As String
    TypeNameJs = HtmlWindowA.eval("Object.prototype.toString.call(" & FullKey(Key) & ")")
End Function

' 获取指定键下的所有子键名称
Function GetAllKeys(Optional KeyName As String) As String()
    Dim KeysCountA As Long
    Dim 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
    Dim 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
    HtmlWindowA.execScript "JsonObj." & ItemName & "=" & vNewValue
    If Err.Number <> 0 Then Debug.Print "ItemEx err:" & Err.Description
End Property

' 返回一行的 JSON 字符串
Public Property Get stringify(Optional ItemName As String, Optional WithVbcrlf As Boolean) As String
    stringify = HtmlWindowA.eval("JSON.stringify(" & "JsonObj" & IIf(ItemName = "", "", "." & ItemName) & IIf(WithVbcrlf, ", null, 2", "") & ")")
End Property

' 将 JSON 字符串解析为 JSON 对象
Public Function parse(ByVal vNewValue As String) As Boolean
    On Error Resume Next
    Doc.Script.SetJsonStr vNewValue
    parse = Err.Number = 0
End Function

' 生成完整的键路径
Private Function FullKey(Key As String) As String
    FullKey = IIf(Key <> "", "JsonObj" & IIf(Left(Key, 1) = "[", "", ".") & Key, "JsonObj")
End Function

' 初始化类
Private Sub Class_Initialize()
    Set Doc = CreateObject("htmlfile")
    Set HtmlWindowA = Doc.parentWindow
    
    ' JSON 2.0.js 代码
    Dim JsCode As String
    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=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""){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){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"");}}}());"
    
    ' 其他 JavaScript 代码
    Dim Sz() As String
    Sz = Split("function JsonFormat(JsonObj_or_Str) { if (JsonObj_or_Str==="""") { return JSON.stringify(JsonObj, null, 2); } else if(typeof JsonObj_or_Str === 'object'){return JSON.stringify(JsonObj_or_Str, null, 2);} else{return JSON.stringify(eval(""JsonObj.""+JsonObj_or_Str), null, 2);} } if (!Object.keys) { Object.keys = (function() { return function(obj) { var keys = []; for (var key in obj) { if (obj.hasOwnProperty(key)) { keys.push(key); } } return keys; }; })(); }", vbCrLf)
    JsCode = JsCode & vbCrLf & Join(Sz, vbCrLf)
    
    HtmlWindowA.execScript JsCode, "JScript"
    Set JsonObj = HtmlWindowA.JsonObj
End Sub

' 获取整个 JSON 对象的字符串表示
Public Property Get JsonStr() As String
    JsonStr = Doc.Script.JsonFormat("")
End Property

' 设置整个 JSON 对象的字符串表示
Public Property Let JsonStr(ByVal vNewValue As String)
    On Error Resume Next
    Doc.Script.SetJsonStr vNewValue
    Set JsonObj = HtmlWindowA.JsonObj
End Property

' 给 Json 设置一整段字符串
Public Function SetJsonStr(JsonStr As String) As Boolean
    On Error Resume Next
    Doc.Script.SetJsonStr JsonStr
    Set JsonObj = HtmlWindowA.JsonObj
    SetJsonStr = Err.Number = 0
End Function

' 返回 JSON 字符串
Public Function GetJsonStr(Optional Key As String) As String
    GetJsonStr = Doc.Script.JsonFormat(Key)
End Function

' 返回指定对象的 JSON 字符串表示
Public Function GetJsonStrObject(obj1 As Object) As String
    GetJsonStrObject = Doc.Script.JsonFormat(obj1)
End Function

' 执行 JavaScript 代码并返回结果
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 = HtmlWindowA.eval("JsonObj." & ItemName & ".length")
End Property

' 删除数组中第 N 个值(INDEX=N-1)
Function RemoveArrayByIndex(ItemName As String, ByVal IndexA As Long) As Boolean
    On Error Resume Next
    HtmlWindowA.execScript "JsonObj." & ItemName & ".splice(" & IndexA & ", 1)"
    RemoveArrayByIndex = Err.Number = 0
End Function

' 数组添加一个值
Public Sub ArrayAdd(ItemName As String, ByVal vNewValue As Variant, Optional AutoSetType As Boolean = True)
    If AutoSetType Then
        If TypeName(vNewValue) = "String" Then vNewValue = """" & vNewValue & """"
    End If
    HtmlWindowA.execScript "JsonObj." & ItemName & ".push(" & vNewValue & ")"
End Sub
VBA解析json示例1
MaFeng
10-13 1644
var cHIsyYjE = {"rc":1,"me":null,"TotalCount":4048062,"pages":1000,"data":[{"codes":[{"short_name":"金龙鱼","market_code":"0","ann_type":"A","stock_code":"300999"}],"notice_date":"2020-10-14 00:00:00","columns":[{"column_code":"001003002004","column_name":"上市
VBA把JSON字符串转为数组，在VBA中解析JSON对象数组为VBA数组对象
lchgwp100的博客
04-07 1545
'VBA把JSON字符串转为数组，在VBA中解析JSON对象数组为VBA数组对象 'Andy 2022.04.07 功能：把VBA获取的网页JSON对象数组，转换成本地VBA数组，供本地程序使用 特色：实现二维表格数据直接转换，在VBA中使用JS代码轻松实现
VBA-JSON:JSON转换和VBA解析
04-30
VBA-JSON VBA（Windows和Mac Excel，Access和其他Office应用程序）的JSON转换和解析。 它出色的项目 ，并进行了添加和改进以解决错误和提高性能（作为一部分）。 在Windows Excel 2013和Excel for Mac 2011中进行了测试，但应适用于2007+。 对于仅Windows支持，请包含对“ Microsoft脚本运行时”的引用 对于Mac和Windows支持，包括 例子 Dim Json As Object Set Json = JsonConverter.ParseJson( "{""a"":123,""b"":[1,2,3,4],""c"":{""d"":456}}" ) ' Json("a") -> 123 ' Json("b")(2) -> 2 ' Json("c")("d") -> 456 Json( "c" )(
VBA解析JSON
118路司机的博客
07-25 1924
vba作为一种古老的语言，是不能直接处理json数据的，但是好在可以加载其他语言的执行引擎，间接的达到解析JSON的目的。
VBA-JSON: 在VBA中轻松处理JSON数据
gitblog_07291的博客
09-13 1486
VBA-JSON: 在VBA中轻松处理JSON数据 项目地址:https://gitcode.com/gh_mirrors/vb/VBA-JSON 项目基础介绍与编程语言 VBA-JSON 是一个专为VBA设计的强大工具库，适用于Windows和Mac环境下的Excel、Access等Office应用程序。此项目基于MIT许可协议开源，并采用了Visual Basic for Applicatio...
Vba Json
海纳百川
12-18 2584
本帖已被收录到知识树中，索引项：网页交互 创建一个“类模块”，命名为“VbaJson” 然后把下面的代码粘贴进去： Private Whitespace, NumberRegex, StringChunk Private b, f, r, n, t Private Sub Class_Initialize
推荐项目：VBA-JSON - VBA中的JSON处理库
gitblog_00100的博客
03-25 1954
推荐项目：VBA-JSON - VBA中的JSON处理库 项目地址:https://gitcode.com/gh_mirrors/vb/VBA-JSON 项目简介 是一个为Microsoft Visual Basic for Applications (VBA) 创建的开源库，用于在VBA中解析和生成JSON（JavaScript Object Notation）数据。如果你经常需要在Excel、...
VBA-JSON-2.3.1_JSON_Windows编程_jsonexcel_ExcelVBA_circleinn_
09-29
在这个项目中，“VBA-JSON-2.3.1”可能就是这样一个库，它提供了函数和方法，使得VBA代码能够方便地解析和生成JSON。 在实际应用中，这个工具可能包括以下步骤： 1. 导入JSON数据：这可能是从网页API、文件或剪贴板...
vba json解析 Dim json As
最新发布
02-21
### 如何在VBA中定义和解析JSON对象 为了处理 JSON 数据，在 VBA 中通常会引入额外的库来简化操作。一种常见的方法是利用 `Microsoft Script Control` 或者第三方类模块如 `JsonConverter.bas` 来实现 JSON 的序列...
vba ajax获取json,EXCEL VBA 网络获取JSON并解读
weixin_33367083的博客
08-06 1138
JSON解读_20191130223712.png第一步，创建从网络获取数据的Function：'-----------------------------------------------'获取网络Json数据(测试成功)'-----------------------------------------------Function getWebData(ByVal URL As String...
VBA将excel数据表生成JSON文件
09-03
本文给大家汇总介绍了几种使用VBA处理EXCEL并生成JSON文件的方法和思路，非常的实用，有需要的小伙伴可以参考下。
Excel VBA解析JSON数据
huaermeier的博客
09-17 7634
JSON本质上是按照JavaScript对象、数组书写的一堆字符串。对于简单的数据可以用split方法、或者使用正则表达式来提取，如果过于复杂就需要用JavaScript语言来解析了。
VBA, json解读,表结构-json字符串互转
m0_56708264的博客
02-13 2157
说明: 不依赖MSScriptControl.ScriptControl,网上收一大堆都是需要依赖MSScriptControl.ScriptControl,但是经常提示"类未注册". WriteJson 将结构体转json字符串 vb中对象需要set, 所以不管根节点是字典还是数组,都封装了一层数组.所以永远返回数组arr. arr只有1个元素 ,判断arr(0)的类型, 字符串型表示error提示, object 或者数组即为成功. arr(0)是json的根节点. writ...
VBA中的json_encode
smcfy的专栏
04-18 1012
最近笔者写vba代码的时候需要将一组数据包装成json数据作为参数传递，然而网上搜索了一圈，并没有发现如PHP的json_encode，decode之类通用的方法。
VBA解析JSON数据（6）-- 解析复杂JSON
热门推荐
神奇的BI
08-01 1万+
JSON数据结构中Array和Object可以嵌套，例如下图所示，body是一个Array，其中的元素为Object（[0], [1], [2] ... ），对象[0]中即包含普通的键值对`c:"商品"`，也包含Object p（其中包含5个键值对），现在需要提前方框标注部分的值。使用VBA按照字符串逐个去解析肯定也可以实现，但是会比较复杂，JSON来自于JavaScript，那么使用JavaScript肯定是最简洁的解决方案。
VBA-JSON：VBA中的JSON转换与解析工具
gitblog_09704的博客
10-19 1237
VBA-JSON：VBA中的JSON转换与解析工具 【下载地址】VBA-JSONVBA中的JSON转换与解析工具 VBA-JSON：VBA中的JSON转换与解析工具VBA-JSON 是一个专为 VBA（Visual Basic for Applications）设计的 JSON 转换和解析工具 ...
VBA 解析JSON文件
记录
08-09 1006
VBA 解析JSON
利用VBA将excel数据表生成JSON文件（utf8）
海纳百川
12-18 5306
ADODB.Stream创建UTF-8+BOM编码的文本文件。 然后遍历数据区，格式化数据，输出即可。 小数据还行，大数据没测试。 另，使用fso创建的文本文件编码为ANSI，ajax解析json时出现乱码无法正常解析。 Sub ToJson() '创建UTF8文本文件  myrange = Worksheets("sheet1").UsedRang
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值