VBA: Access JSON

Question

Я работаю над проекцией VBA и не уверен, как получить доступ к «id» в этом JSON. Для чего нужно «игроков» установить id в цикле?

Я обновил вопрос с большим количеством кода.

JSON

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

Код

Спасибо за взглянуть.

Answer 1

Рассмотрим следующий пример относительно реализации JSON синтаксического анализа в VBA:

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. Предположим, что вы разбираете ответ веб-сервера JSON, например JsonString = "{a:(function(){(new ActiveXObject('Scripting.FileSystemObject')).CreateTextFile('C:\\Test.txt')})()}". После его оценки вы найдете новый созданный файл C:\Test.txt. Итак, JSON разбор с ScriptControl ActiveX - не очень хорошая идея.

Попытка избежать этого, я создал парсер JSON на основе RegEx. Объекты {} представлены словарями, которые позволяют использовать свойства и методы словаря: .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 

Вы можете найти full version by the link.