用VBS解析JSON格式数据之VbsJson类

标签: , , , ,

曾经写过一篇《用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。

赞赏

微信赞赏支付宝赞赏

随机文章:

  1. VBS 获取外网 IP 并发送到指定邮箱
  2. NDS上的NeoGeo模拟器NeoDS
  3. 在C语言程序中嵌入Lua脚本
  4. VBS实现全角字符转半角字符
  5. 再谈CreateObject函数,VBS到底能调用哪些对象?

66 条评论 发表在“用VBS解析JSON格式数据之VbsJson类”上

  1. somebody说道:

    148行
    ParseArray函数

    If c = “]” Then
    idx = idx + 1 ‘缺少这个
    ParseArray = values.Items
    Exit Function
    End If

    • somebody说道:

      248行 -_-!
      解析空数组错误

    • gjac说道:

      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 !

      • ambasad说道:

        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

        • Tim Jager说道:

          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

          • Anonymus说道:

            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

  2. sundaytwins说道:

    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?

  3. Mike说道:

    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”]’

  4. super_admi说道:

    Example.vbs这个文件里面,不可以直接New一个VbsJson对象吗?难道一定要把这个文件和VbsJson.vbs合并才行?

    直接运行Example.vbs提示VbsJson类没有定义。

    • 7qinq说道:

      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

  5. […] Usa este, que parece funcionar en mi caso: demonio.tw […]

  6. lin说道:

    问下encode的用法,每次都初始化buf,怎么add新的item进去

  7. PY-DNG说道:

    …解析空对象或者空数组的时候会出现错误,原因是直接Exit Function没有写id = idx + 1,加上以后就好了
    这个BUG查了我好几天,结果发现原来早在三年前就有人反馈过了↓,佩服

  8. garolgarel说道:

    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).

  9. garolgarel说道:

    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!

  10. Peter说道:

    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?

留下回复