标题: 用VBS解析JSON格式数据之VbsJson类
作者: Demon
链接: https://demon.tw/my-work/vbs-json.html
版权: 本博客的所有文章，都遵守“署名-非商业性使用-相同方式共享 2.5 中国大陆”协议条款。
曾经写过一篇《用VBS解析JSON格式数据》，里面提到了用 VBS 解析 JSON 的三种方法：：第一，根据算法自己写一个解析 JSON 的库；第二，使用正则表达式匹配需要的数据；第三，用 JavaScript 来解析。
文章中使用的是第三种方法，即通过 MSScriptControl.ScriptControl 组件来调用 JavaScript 来解析。“乱码”根据那篇文章写了《VBS脚本之JSON数据解析》，稍稍改进了我的方法；不过他最近发现这个组件兼容性不太好，并写了一篇《VBS脚本之JSON数据解析(二)》，里面是用正则表达式来解析 JSON 的；之后又写了一篇《VBS脚本之JSON数据解析(三)[终章]》，里面用 htmlfile 来代替 MSScriptControl.ScriptControl，增强了可移植性：
Function ParseJson(strJson) Set html = CreateObject("htmlfile") Set window = html.parentWindow window.execScript "var json = " & strJson, "JScript" Set ParseJson = window.json End Function
不得不说这个方法很巧妙，但是却不能遍历数组和对象，作为“终章”似乎还差了一点，本文就是作为终章的存在：用 Native VBScript 来解析 JSON —— VbsJson类。该类提供了两个公有方法：Encode 和 Decode，分别用来生成和解析 JSON 数据。
VbsJson.vbs
Class VbsJson 'Author: Demon 'Date: 2012/5/3 'Website: https://demon.tw Private Whitespace, NumberRegex, StringChunk Private b, f, r, n, t Private Sub Class_Initialize Whitespace = " " & vbTab & vbCr & vbLf b = ChrW(8) f = vbFormFeed r = vbCr n = vbLf t = vbTab Set NumberRegex = New RegExp NumberRegex.Pattern = "(-?(?:0|[1-9]\d*))(\.\d+)?([eE][-+]?\d+)?" NumberRegex.Global = False NumberRegex.MultiLine = True NumberRegex.IgnoreCase = True Set StringChunk = New RegExp StringChunk.Pattern = "([\s\S]*?)([""\\\x00-\x1f])" StringChunk.Global = False StringChunk.MultiLine = True StringChunk.IgnoreCase = True End Sub 'Return a JSON string representation of a VBScript data structure 'Supports the following objects and types '+-------------------+---------------+ '| VBScript | JSON | '+===================+===============+ '| Dictionary | object | '+-------------------+---------------+ '| Array | array | '+-------------------+---------------+ '| String | string | '+-------------------+---------------+ '| Number | number | '+-------------------+---------------+ '| True | true | '+-------------------+---------------+ '| False | false | '+-------------------+---------------+ '| Null | null | '+-------------------+---------------+ Public Function Encode(ByRef obj) Dim buf, i, c, g Set buf = CreateObject("Scripting.Dictionary") Select Case VarType(obj) Case vbNull buf.Add buf.Count, "null" Case vbBoolean If obj Then buf.Add buf.Count, "true" Else buf.Add buf.Count, "false" End If Case vbInteger, vbLong, vbSingle, vbDouble buf.Add buf.Count, obj Case vbString buf.Add buf.Count, """" For i = 1 To Len(obj) c = Mid(obj, i, 1) Select Case c Case """" buf.Add buf.Count, "\""" Case "\" buf.Add buf.Count, "\\" Case "/" buf.Add buf.Count, "/" Case b buf.Add buf.Count, "\b" Case f buf.Add buf.Count, "\f" Case r buf.Add buf.Count, "\r" Case n buf.Add buf.Count, "\n" Case t buf.Add buf.Count, "\t" Case Else If AscW(c) >= 0 And AscW(c) <= 31 Then c = Right("0" & Hex(AscW(c)), 2) buf.Add buf.Count, "\u00" & c Else buf.Add buf.Count, c End If End Select Next buf.Add buf.Count, """" Case vbArray + vbVariant g = True buf.Add buf.Count, "[" For Each i In obj If g Then g = False Else buf.Add buf.Count, "," buf.Add buf.Count, Encode(i) Next buf.Add buf.Count, "]" Case vbObject If TypeName(obj) = "Dictionary" Then g = True buf.Add buf.Count, "{" For Each i In obj If g Then g = False Else buf.Add buf.Count, "," buf.Add buf.Count, """" & i & """" & ":" & Encode(obj(i)) Next buf.Add buf.Count, "}" Else Err.Raise 8732,,"None dictionary object" End If Case Else buf.Add buf.Count, """" & CStr(obj) & """" End Select Encode = Join(buf.Items, "") End Function 'Return the VBScript representation of ``str(`` 'Performs the following translations in decoding '+---------------+-------------------+ '| JSON | VBScript | '+===============+===================+ '| object | Dictionary | '+---------------+-------------------+ '| array | Array | '+---------------+-------------------+ '| string | String | '+---------------+-------------------+ '| number | Double | '+---------------+-------------------+ '| true | True | '+---------------+-------------------+ '| false | False | '+---------------+-------------------+ '| null | Null | '+---------------+-------------------+ Public Function Decode(ByRef str) Dim idx idx = SkipWhitespace(str, 1) If Mid(str, idx, 1) = "{" Then Set Decode = ScanOnce(str, 1) Else Decode = ScanOnce(str, 1) End If End Function Private Function ScanOnce(ByRef str, ByRef idx) Dim c, ms idx = SkipWhitespace(str, idx) c = Mid(str, idx, 1) If c = "{" Then idx = idx + 1 Set ScanOnce = ParseObject(str, idx) Exit Function ElseIf c = "[" Then idx = idx + 1 ScanOnce = ParseArray(str, idx) Exit Function ElseIf c = """" Then idx = idx + 1 ScanOnce = ParseString(str, idx) Exit Function ElseIf c = "n" And StrComp("null", Mid(str, idx, 4)) = 0 Then idx = idx + 4 ScanOnce = Null Exit Function ElseIf c = "t" And StrComp("true", Mid(str, idx, 4)) = 0 Then idx = idx + 4 ScanOnce = True Exit Function ElseIf c = "f" And StrComp("false", Mid(str, idx, 5)) = 0 Then idx = idx + 5 ScanOnce = False Exit Function End If Set ms = NumberRegex.Execute(Mid(str, idx)) If ms.Count = 1 Then idx = idx + ms(0).Length ScanOnce = CDbl(ms(0)) Exit Function End If Err.Raise 8732,,"No JSON object could be ScanOnced" End Function Private Function ParseObject(ByRef str, ByRef idx) Dim c, key, value Set ParseObject = CreateObject("Scripting.Dictionary") idx = SkipWhitespace(str, idx) c = Mid(str, idx, 1) If c = "}" Then Exit Function ElseIf c <> """" Then Err.Raise 8732,,"Expecting property name" End If idx = idx + 1 Do key = ParseString(str, idx) idx = SkipWhitespace(str, idx) If Mid(str, idx, 1) <> ":" Then Err.Raise 8732,,"Expecting : delimiter" End If idx = SkipWhitespace(str, idx + 1) If Mid(str, idx, 1) = "{" Then Set value = ScanOnce(str, idx) Else value = ScanOnce(str, idx) End If ParseObject.Add key, value idx = SkipWhitespace(str, idx) c = Mid(str, idx, 1) If c = "}" Then Exit Do ElseIf c <> "," Then Err.Raise 8732,,"Expecting , delimiter" End If idx = SkipWhitespace(str, idx + 1) c = Mid(str, idx, 1) If c <> """" Then Err.Raise 8732,,"Expecting property name" End If idx = idx + 1 Loop idx = idx + 1 End Function Private Function ParseArray(ByRef str, ByRef idx) Dim c, values, value Set values = CreateObject("Scripting.Dictionary") idx = SkipWhitespace(str, idx) c = Mid(str, idx, 1) If c = "]" Then ParseArray = values.Items Exit Function End If Do idx = SkipWhitespace(str, idx) If Mid(str, idx, 1) = "{" Then Set value = ScanOnce(str, idx) Else value = ScanOnce(str, idx) End If values.Add values.Count, value idx = SkipWhitespace(str, idx) c = Mid(str, idx, 1) If c = "]" Then Exit Do ElseIf c <> "," Then Err.Raise 8732,,"Expecting , delimiter" End If idx = idx + 1 Loop idx = idx + 1 ParseArray = values.Items End Function Private Function ParseString(ByRef str, ByRef idx) Dim chunks, content, terminator, ms, esc, char Set chunks = CreateObject("Scripting.Dictionary") Do Set ms = StringChunk.Execute(Mid(str, idx)) If ms.Count = 0 Then Err.Raise 8732,,"Unterminated string starting" End If content = ms(0).Submatches(0) terminator = ms(0).Submatches(1) If Len(content) > 0 Then chunks.Add chunks.Count, content End If idx = idx + ms(0).Length If terminator = """" Then Exit Do ElseIf terminator <> "\" Then Err.Raise 8732,,"Invalid control character" End If esc = Mid(str, idx, 1) If esc <> "u" Then Select Case esc Case """" char = """" Case "\" char = "\" Case "/" char = "/" Case "b" char = b Case "f" char = f Case "n" char = n Case "r" char = r Case "t" char = t Case Else Err.Raise 8732,,"Invalid escape" End Select idx = idx + 1 Else char = ChrW("&H" & Mid(str, idx + 1, 4)) idx = idx + 5 End If chunks.Add chunks.Count, char Loop ParseString = Join(chunks.Items, "") End Function Private Function SkipWhitespace(ByRef str, ByVal idx) Do While idx <= Len(str) And _ InStr(Whitespace, Mid(str, idx, 1)) > 0 idx = idx + 1 Loop SkipWhitespace = idx End Function End Class
Example.vbs
'Author: Demon 'Date: 2012/5/3 'Website: https://demon.tw Dim fso, json, str, o, i Set json = New VbsJson Set fso = WScript.CreateObject("Scripting.Filesystemobject") str = fso.OpenTextFile("json.txt").ReadAll Set o = json.Decode(str) WScript.Echo o("Image")("Width") WScript.Echo o("Image")("Height") WScript.Echo o("Image")("Title") WScript.Echo o("Image")("Thumbnail")("Url") For Each i In o("Image")("IDs") WScript.Echo i Next
json.txt
{
"Image": {
"Width": 800,
"Height": 600,
"Title": "View from 15th Floor",
"Thumbnail": {
"Url": "http://www.example.com/image/481989943",
"Height": 125,
"Width": "100"
},
"IDs": [116, 943, 234, 38793]
}
}
欢迎测试和反馈BUG。
赞赏
微信赞赏
支付宝赞赏
随机文章:
麻烦不，Python直接就自带json模块
我电脑没 Py 那该怎么办？
Function ParseJson(strJson)
Set html = CreateObject(“htmlfile”)
Set window = html.parentWindow
window.execScript “var json = ” & strJson, “JScript”
Set ParseJson = window.json
End Function
博主在文章中提到“但是却不能遍历数组和对象”，这个是错误的，这个方法不但巧妙，而且完全可以遍历数组，只不过vbs遍历数组的方式不一样罢了，一下是改进后的代码：
Function ParseJson(strJson)
Set html = CreateObject(“htmlfile”)
Set window = html.parentWindow
window.execScript “var json = ” & strJson, “JScript”
Set Jsons = window.json
For Each Json in Jsons
WScript.Echo Json.成员
Next
End Function
js和vbs遍历的方法有区别，希望可以和博主多交流，我的QQ:362760790
For Each Json in Jsons
WScript.Echo Json.成员
Next
这个我试了一下，似乎不行
请问如何使用Encode方法
BugReport:
采用VbsJson.vbs解析JSON格式信息时,当文本中存在空对象表示时会半途退出解析,初步判断是ParseObject(ByRef str, ByRef idx)中对”}”处理的地方有问题导致,测试用例:
Sub testVBAJSON()
Dim jsonStr As String, json
jsonStr = “{“”a””:{},””b””:1}”
Set json = New VbsJson
msgbox json.Encode(json.Decode(jsonStr))
End Sub
得到的是{“a”:{}}而不是{“a”:{},”b”:1}
怀疑的出错的地点为 If c = “}” Then Exit Do,简单修改没成功,先反馈下.
另外,感谢作者提供这样一个类给大家,谢谢.
If c = “}” Then下面加一行
idx = idx + 1 ‘处理类似这样的字符串 {“a”:{}}
ParseArray = values.Items下面加一行
idx = idx + 1 ‘处理类似这样的字符串 {“a”:[]}
Public Function Decode(ByRef str)
下面加一行
str = Replace(str, “{}”, &0)
很残暴
I’m getting an error on this line of code:
Set o = json.Decode(str)
Microsoft VBScript runtime error ‘800a01a8’
Object required: ‘[number: 800]’
Can anyone help me. I’m not a hardcore programmer. Just copying this and running it on the server.
真是好东西啊~~多谢多谢!!
hi
is it possible to encode excel workbook as json using this
i tried it but git some error as null value property error
非常感谢，已经引用，并在文档里写了网址作为出处。
确实强大，应用了，已声明为作者原创。
这是我的改进版，增添了一些功能，望高手指教：
http://blog.csdn.net/sd7056333/article/details/49817905