VBA：访问 JSON

我正在处理 VBA 投影，但不确定如何访问此 JSON 中的“id”。应该将“players”设置为什么才能在循环中获取 id？

我已经用更多代码更新了问题。

JSON

{  
   "event_games":[  
       {  
       "players":[  
           {
               "id":182759
            }
         ]
      }
   ]
}

Code

Private Function getPlayerID(sport As String)
    Dim JSONHttp As New MSXML2.XMLHTTP30
    Dim conn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim playerID As String
    Dim p As Object
    Dim players As Object
    Dim x As Integer

    On Error GoTo errHandler

    JSONHttp.Open "GET", url, False
    JSONHttp.send

    response = JSONHttp.responseText
    Set p = JSON.parse(response)
    Set players = p.Item("event_games")

    If openConnection(conn, gstrConnection) Then

        For x = 1 To players.Count

            playerID= players.Item("players").Item("id")
            LogWrite Now & " " & playerID

        Next
    Else
        LogWrite Now & " Could not load. Error. " & response
End If

Exit Function
errHandler:

    LogWrite Now & ":" & Err.Number & " - " & Err.Description
    Resume Next

End Function

谢谢参观。

考虑以下有关在 VBA 中实现 JSON 解析的示例：

Sub JsonTest()
    Dim response As String
    Dim p As Object
    Dim x As Long
    response = "{'event_games':[{'players':[{'id':182759},{'id':182760},{'id':182761}]}]}"
    Set p = GetJsonDict(response)
    Set players = p("event_games")(0)("players")
    For x = 1 To players.Count
        playerID = players(x - 1)("id")
        MsgBox "player " & x & ", playerID " & playerID
    Next
End Sub

Function GetJsonDict(JsonString As String)
    With CreateObject("ScriptControl")
        .Language = "JScript"
        .ExecuteStatement "function gettype(sample) {return {}.toString.call(sample).slice(8, -1)}"
        .ExecuteStatement "function evaljson(json, er) {try {var sample = eval('(' + json + ')'); var type = gettype(sample); if(type != 'Array' && type != 'Object') {return er;} else {return getdict(sample);}} catch(e) {return er;}}"
        .ExecuteStatement "function getdict(sample) {var type = gettype(sample); if(type != 'Array' && type != 'Object') return sample; var dict = new ActiveXObject('Scripting.Dictionary'); if(type == 'Array') {for(var key = 0; key < sample.length; key++) {dict.add(key, getdict(sample[key]));}} else {for(var key in sample) {dict.add(key, getdict(sample[key]));}} return dict;}"
        Set GetJsonDict = .Run("evaljson", JsonString, Nothing)
    End With
End Function

UPDATE

请注意，上述方法在某些情况下会使系统容易受到攻击，因为它允许恶意 JS 代码通过 ActiveX 直接访问驱动器（和其他内容）。假设您正在解析 Web 服务器响应 JSON，例如JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}"。评估后你会发现新创建的文件C:\Test.txt。所以 JSON 解析为ScriptControlActiveX 不是一个好主意。

为了避免这种情况，我创建了基于 RegEx 的 JSON 解析器。对象{}由字典表示，这使得使用字典的属性和方法成为可能：.Count, .Exists(), .Item(), .Items, .Keys。数组[]是传统的从零开始的 VB 数组，所以UBound()显示元素的数量。这是带有一些用法示例的代码：

Option Explicit

Sub JsonTest()
    Dim response As String
    Dim p As Variant
    Dim state As String
    Dim players() As Variant
    Dim x As Long
    Dim playerID As String
    response = "{""event_games"":[{""players"":[{""id"":182759},{""id"":182760},{""id"":182761}]}]}"
    ParseJson response, p, state
    players = p("event_games")(0)("players")
    For x = 0 To UBound(players)
        playerID = players(x)("id")
        MsgBox "player " & x & ", playerID " & playerID
    Next
End Sub

Sub ParseJson(ByVal strContent As String, varJson As Variant, strState As String)
    ' strContent - source JSON string
    ' varJson - created object or array to be returned as result
    ' strState - Object|Array|Error depending on processing to be returned as state
    Dim objTokens As Object
    Dim objRegEx As Object
    Dim bMatched As Boolean

    Set objTokens = CreateObject("Scripting.Dictionary")
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        ' specification http://www.json.org/
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        .Pattern = """(?:\\""|[^""])*""(?=\s*(?:,|\:|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "str"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)e(?:[+-])?\d+(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "(?:[+-])?(?:\d+\.\d*|\.\d+|\d+)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "num"
        .Pattern = "\b(?:true|false|null)(?=\s*(?:,|\]|\}))"
        Tokenize objTokens, objRegEx, strContent, bMatched, "cst"
        .Pattern = "\b[A-Za-z_]\w*(?=\s*\:)" ' unspecified name without quotes
        Tokenize objTokens, objRegEx, strContent, bMatched, "nam"
        .Pattern = "\s"
        strContent = .Replace(strContent, "")
        .MultiLine = False
        Do
            bMatched = False
            .Pattern = "<\d+(?:str|nam)>\:<\d+(?:str|num|obj|arr|cst)>"
            Tokenize objTokens, objRegEx, strContent, bMatched, "prp"
            .Pattern = "\{(?:<\d+prp>(?:,<\d+prp>)*)?\}"
            Tokenize objTokens, objRegEx, strContent, bMatched, "obj"
            .Pattern = "\[(?:<\d+(?:str|num|obj|arr|cst)>(?:,<\d+(?:str|num|obj|arr|cst)>)*)?\]"
            Tokenize objTokens, objRegEx, strContent, bMatched, "arr"
        Loop While bMatched
        .Pattern = "^<\d+(?:obj|arr)>$" ' unspecified top level array
        If Not (.Test(strContent) And objTokens.Exists(strContent)) Then
            varJson = Null
            strState = "Error"
        Else
            Retrieve objTokens, objRegEx, strContent, varJson
            strState = IIf(IsObject(varJson), "Object", "Array")
        End If
    End With
End Sub

Sub Tokenize(objTokens, objRegEx, strContent, bMatched, strType)
    Dim strKey As String
    Dim strRes As String
    Dim lngCopyIndex As Long
    Dim objMatch As Object

    strRes = ""
    lngCopyIndex = 1
    With objRegEx
        For Each objMatch In .Execute(strContent)
            strKey = "<" & objTokens.Count & strType & ">"
            bMatched = True
            With objMatch
                objTokens(strKey) = .Value
                strRes = strRes & Mid(strContent, lngCopyIndex, .FirstIndex - lngCopyIndex + 1) & strKey
                lngCopyIndex = .FirstIndex + .Length + 1
            End With
        Next
        strContent = strRes & Mid(strContent, lngCopyIndex, Len(strContent) - lngCopyIndex + 1)
    End With
End Sub

Sub Retrieve(objTokens, objRegEx, strTokenKey, varTransfer)
    Dim strContent As String
    Dim strType As String
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strName As String
    Dim varValue As Variant
    Dim objArrayElts As Object

    strType = Left(Right(strTokenKey, 4), 3)
    strContent = objTokens(strTokenKey)
    With objRegEx
        .Global = True
        Select Case strType
            Case "obj"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set varTransfer = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varTransfer
                Next
            Case "prp"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)

                Retrieve objTokens, objRegEx, objMatches(0).Value, strName
                Retrieve objTokens, objRegEx, objMatches(1).Value, varValue
                If IsObject(varValue) Then
                    Set varTransfer(strName) = varValue
                Else
                    varTransfer(strName) = varValue
                End If
            Case "arr"
                .Pattern = "<\d+\w{3}>"
                Set objMatches = .Execute(strContent)
                Set objArrayElts = CreateObject("Scripting.Dictionary")
                For Each objMatch In objMatches
                    Retrieve objTokens, objRegEx, objMatch.Value, varValue
                    If IsObject(varValue) Then
                        Set objArrayElts(objArrayElts.Count) = varValue
                    Else
                        objArrayElts(objArrayElts.Count) = varValue
                    End If
                    varTransfer = objArrayElts.Items
                Next
            Case "nam"
                varTransfer = strContent
            Case "str"
                varTransfer = Mid(strContent, 2, Len(strContent) - 2)
                varTransfer = Replace(varTransfer, "\""", """")
                varTransfer = Replace(varTransfer, "\\", "\")
                varTransfer = Replace(varTransfer, "\/", "/")
                varTransfer = Replace(varTransfer, "\b", Chr(8))
                varTransfer = Replace(varTransfer, "\f", Chr(12))
                varTransfer = Replace(varTransfer, "\n", vbLf)
                varTransfer = Replace(varTransfer, "\r", vbCr)
                varTransfer = Replace(varTransfer, "\t", vbTab)
                .Global = False
                .Pattern = "\\u[0-9a-fA-F]{4}"
                Do While .Test(varTransfer)
                    varTransfer = .Replace(varTransfer, ChrW(("&H" & Right(.Execute(varTransfer)(0).Value, 4)) * 1))
                Loop
            Case "num"
                varTransfer = Evaluate(strContent)
            Case "cst"
                Select Case LCase(strContent)
                    Case "true"
                        varTransfer = True
                    Case "false"
                        varTransfer = False
                    Case "null"
                        varTransfer = Null
                End Select
        End Select
    End With
End Sub

您可以找到完整版通过链接 https://stackoverflow.com/a/30494373/2165759.