标题: 用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。
赞赏
微信赞赏
支付宝赞赏
随机文章:
148行
ParseArray函数
If c = “]” Then
idx = idx + 1 ‘缺少这个
ParseArray = values.Items
Exit Function
End If
248行 -_-!
解析空数组错误
hi guy,
your comment save my life !… not realy but it save a lot of my time !!!
Thank you very much and thanks for this script !
Hi!
You can fix it like this: in Public Function Decode need add stirng str=Replace(str,”[]”,”[“”””]”)
Public Function Decode(ByRef str)
Dim idx
str=Replace(str,”[]”,”[“”””]”)
idx = SkipWhitespace(str, 1)
If Mid(str, idx, 1) = “{” Then
Set Decode = ScanOnce(str, 1)
Else
Decode = ScanOnce(str, 1)
End If
End Function
The function will also fail if it encounters an empty object. For example “myObject”:{}
You can fix this by also adding a handler for empty objects in Public Function Decode as shown below:
Public Function Decode(ByRef str)
Dim idx
str=Replace(str,”[]”,”[“”””]”) ‘This handles empty arrays by replacing them with empty quotes
str=Replace(str,”{}”,”[“”””]”) ‘This handles empty objects by replacing them with empty quotes
idx = SkipWhitespace(str, 1)
If Mid(str, idx, 1) = “{” Then
Set Decode = ScanOnce(str, 1)
Else
Decode = ScanOnce(str, 1)
End If
End Function
My solution is modifying these two functions:
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
idx = idx + 1 ‘modified
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
idx = idx + 1 ‘modified
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
is there a way to decode json file with more than 2 occurences of the same element.
ie two times the ‘image’ in your example?
Looks like it does not handle JSON correctly.
Consider the following json:
{
“success”: true,
“data”: [
{
“id”: “5”,
“user_id”: “1”,
“room_id”: “3”,
“topic”: “new tst “,
“from”: “2016-12-08 13:00:00”,
“to”: “2016-12-08 19:00:00”,
“created_at”: “2016-12-08 14:02:48”,
“updated_at”: “2016-12-08 14:02:48”
}
],
“message”: “Conference retrieved successfully”
}
With that in mind, the following doesn’t work:
WScript.Echo o(“data”)(“topic”) gives the following error:
Type mismatch: ‘[string: “topic”]’
改成WScript.Echo o(“data”)(0)(“topic”)
Example.vbs这个文件里面，不可以直接New一个VbsJson对象吗？难道一定要把这个文件和VbsJson.vbs合并才行？
直接运行Example.vbs提示VbsJson类没有定义。
Include “VbsJson.vbs”
Function Include(filePath)
Set stm = WScript.CreateObject(“Adodb.Stream”)
stm.Type = 2
stm.mode = 3
stm.charset = “utf-8”
stm.Open
stm.LoadFromFile filePath
filestr = stm.readtext
stm.close
‘TracePrint filestr
ExecuteGlobal filestr
End Function
[…] Usa este, que parece funcionar en mi caso: demonio.tw […]
问下encode的用法，每次都初始化buf,怎么add新的item进去
…解析空对象或者空数组的时候会出现错误，原因是直接Exit Function没有写id = idx + 1，加上以后就好了
这个BUG查了我好几天，结果发现原来早在三年前就有人反馈过了↓，佩服
说错了，是idx = idx + 1，不是id = idx + 1(-_-)|||
Hi!
Thank you very much for this simple and easy usable code.
Can you explain how to access an item by his position?
For example:
I have a Json with this structure:
“payment”:{
“total”: 450.01,
“methods”:[
{
“type”: 1,
“amount”: 30.01,
“aditionalInfo”: {
“pepe”: 20,
“pepe1”: “ABC1234”
}
},
{
“type”: 2,
“amount”: 220.01,
“aditionalInfo”: {
“code1”: “417006”,
“code2”: “8020”,
“code3”: 11,
“code4”: 2025,
“code5”: “Robert Smith”,
“cardhold”: “49684611”
}
},
{
“type”: 3,
“amount”: 200.01,
“aditionalInfo”: {
“code1”: “417006”,
“code2”: “8020”,
“code3”: 11,
“code4”: 2025,
“code5”: “Robert Smith”,
“cardhold”: “49684611”
}
}
]}
I can access directly very easy this way:
o(“payment”)(“methods”)(0)(“aditionalInfo”)(“code2”)
and of I can know hoy many items are in with o(“payment”)(“methods”)(0)(“aditionalInfo”).Count but I can’t figure how to access individually by an iteration:
x = 0
For Each i In o(“payment”)(“methods”)
metodos(x,0,0)= i(“type”)
metodos(x,1,0)= colocarDecimal(i(“amount”))
for z =0 to i(“aditionalInfo”).Count -1
metodos(x,2,z)= i(“aditionalInfo”)(z) // not working, //.value(z) not working // .item(z) not working
next
x = x +1
Next
If there is any possibility I will thank you!
Note: I make the function colocarDecimal for the numeric values with decimal point in order to format the number (for example: 500.50 using your code actually responses 50050).
Solved by me this way:
x = 0
For Each i In o(“payment”)(“methods”)
metodos(x,0,0)= “type:”& i(“type”)
metodos(x,1,0)= “amount:” & colocarDecimal(i(“amount”))
w = 0
for each v in i(“aditionalInfo”)
metodos(x,2,w) = v& “:” & i(“aditionalInfo”)(v)
w = w+1
next
x = x +1
Next
Thank you!
Hallo and thanks for your Solutions.
Decoding is working for me. How should i use Encoding? by unsing the outcome of decoding, i always get a “encode typeconfict” it is a dictionary and it is vbObject. any idea?