Правильный анализ текста ответа JSON - PullRequest
Новая
       5

Правильный анализ текста ответа JSON

0 голосов
/ 13 января 2019

У меня проблема в программе Excel, которую я создаю. Короче говоря, мне нужно извлечь данные JSON с веб-сайта, проанализировать их и выбросить ответ на лист для дальнейшего использования. Всякий раз, когда код достигает точки, в которой он собирается вывести текст ответа, на выходе передается первый набор данных, который мне нужен, из текста ответа. Все данные и примеры приведены ниже.

Код, который создает и отправляет HTTP-запрос: 

For i = 1 To 100
    URL = "REDACTED"

Set httpRequest = CreateObject("MSXML2.XMLHTTP")
httpRequest.Open "GET", URL, False
httpRequest.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
httpRequest.send ""

Set Output = parse(httpRequest.responseText)

Pallet_Inv.Cells(1 + i, d) = Output.Item("result").Item("contains").Item(i).Item("resourceLabel")

Next

Pallet_Inv - лист, на который должен быть выведен текст ответа. "(1 + i, d)" есть, поскольку у меня есть заголовок на листе, к которому идет вывод, который я не хочу переопределять.

Код, который анализирует текст ответа, который возвращается из запроса: 

Public Function parse(ByRef str As String) As Object

   Dim Index As Long
   Index = 1
   psErrors = ""
   On Error Resume Next
   Call skipChar(str, Index)
   Select Case Mid(str, Index, 1)
      Case "{"
         Set parse = parseObject(str, Index)
      Case "["
         Set parse = parseArray(str, Index)
      Case Else
         psErrors = "Invalid JSON"
   End Select


End Function
'   skip special character
'
Private Sub skipChar(ByRef str As String, ByRef Index As Long)
   Dim bComment As Boolean
   Dim bStartComment As Boolean
   Dim bLongComment As Boolean
   Do While Index > 0 And Index <= Len(str)
      Select Case Mid(str, Index, 1)
      Case vbCr, vbLf
         If Not bLongComment Then
            bStartComment = False
            bComment = False
         End If

      Case vbTab, " ", "(", ")"

      Case "/"
         If Not bLongComment Then
            If bStartComment Then
               bStartComment = False
               bComment = True
            Else
               bStartComment = True
               bComment = False
               bLongComment = False
            End If
         Else
            If bStartComment Then
               bLongComment = False
               bStartComment = False
               bComment = False
            End If
         End If

      Case "*"
         If bStartComment Then
            bStartComment = False
            bComment = True
            bLongComment = True
         Else
            bStartComment = True
         End If

      Case Else
         If Not bComment Then
            Exit Do
         End If
      End Select

      Index = Index + 1
   Loop

 End Sub
 '
 '   parse collection of key/value
 '
Private Function parseObject(ByRef str As String, ByRef Index As Long) As Dictionary

   Set parseObject = New Dictionary
   Dim sKey As String

   ' "{"
   Call skipChar(str, Index)
   If Mid(str, Index, 1) <> "{" Then
      psErrors = psErrors & "Invalid Object at position " & Index & " : " & Mid(str, Index) & vbCrLf
      Exit Function
   End If

   Index = Index + 1

   Do
      Call skipChar(str, Index)
      If "}" = Mid(str, Index, 1) Then
         Index = Index + 1
         Exit Do
      ElseIf "," = Mid(str, Index, 1) Then
         Index = Index + 1
         Call skipChar(str, Index)
      ElseIf Index > Len(str) Then
         psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf
         Exit Do
      End If


      ' add key/value pair
      sKey = parseKey(str, Index)
      On Error Resume Next

      parseObject.Add sKey, parseValue(str, Index)
      If Err.Number <> 0 Then
         psErrors = psErrors & Err.Description & ": " & sKey & vbCrLf
         Exit Do
      End If
   Loop
eh:

End Function

Private Function parseKey(ByRef str As String, ByRef Index As Long) As String

   Dim dquote  As Boolean
   Dim squote  As Boolean
   Dim Char    As String

   Call skipChar(str, Index)
   Do While Index > 0 And Index <= Len(str)
      Char = Mid(str, Index, 1)
      Select Case (Char)
         Case """"
            dquote = Not dquote
            Index = Index + 1
            If Not dquote Then
               Call skipChar(str, Index)
               If Mid(str, Index, 1) <> ":" Then
                  psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
                  Exit Do
               End If
            End If
         Case "'"
            squote = Not squote
            Index = Index + 1
            If Not squote Then
               Call skipChar(str, Index)
               If Mid(str, Index, 1) <> ":" Then
                  psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
                  Exit Do
               End If
            End If
         Case ":"
            Index = Index + 1
            If Not dquote And Not squote Then
               Exit Do
            Else
               parseKey = parseKey & Char
            End If
         Case Else
            If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then
            Else
               parseKey = parseKey & Char
            End If
            Index = Index + 1
      End Select
   Loop

End Function
'
'   parse string / number / object / array / true / false / null
'
Private Function parseValue(ByRef str As String, ByRef Index As Long)

   Call skipChar(str, Index)

   Select Case Mid(str, Index, 1)
      Case "{"
         Set parseValue = parseObject(str, Index)
      Case "["
         Set parseValue = parseArray(str, Index)
      Case """", "'"
         parseValue = parseString(str, Index)
      Case "t", "f"
         parseValue = parseBoolean(str, Index)
      Case "n"
         parseValue = parseNull(str, Index)
      Case Else
         parseValue = parseNumber(str, Index)
   End Select

End Function
'
'   parse list
'
Private Function parseArray(ByRef str As String, ByRef Index As Long) As Collection

   Set parseArray = New Collection

   ' "["
   Call skipChar(str, Index)
   If Mid(str, Index, 1) <> "[" Then
      psErrors = psErrors & "Invalid Array at position " & Index & " : " + Mid(str, Index, 20) & vbCrLf
      Exit Function
   End If

   Index = Index + 1

   Do

      Call skipChar(str, Index)
      If "]" = Mid(str, Index, 1) Then
         Index = Index + 1
         Exit Do
      ElseIf "," = Mid(str, Index, 1) Then
         Index = Index + 1
         Call skipChar(str, Index)
      ElseIf Index > Len(str) Then
         psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf
         Exit Do
      End If

      ' add value
      On Error Resume Next
      parseArray.Add parseValue(str, Index)
      If Err.Number <> 0 Then
         psErrors = psErrors & Err.Description & ": " & Mid(str, Index, 20) & vbCrLf
         Exit Do
      End If
   Loop

End Function
'
'   parse number
'
Private Function parseNumber(ByRef str As String, ByRef Index As Long)

   Dim Value   As String
   Dim Char    As String

   Call skipChar(str, Index)
   Do While Index > 0 And Index <= Len(str)
      Char = Mid(str, Index, 1)
      If InStr("+-0123456789.eE", Char) Then
         Value = Value & Char
         Index = Index + 1
      Else
         parseNumber = CDec(Value)
         Exit Function
      End If
   Loop
End Function
'
'   parse string
'
Private Function parseString(ByRef str As String, ByRef Index As Long) As String

   Dim quote   As String
   Dim Char    As String
   Dim Code    As String

   Dim SB As New cStringBuilder

   Call skipChar(str, Index)
   quote = Mid(str, Index, 1)
   Index = Index + 1

   Do While Index > 0 And Index <= Len(str)
      Char = Mid(str, Index, 1)
      Select Case (Char)
         Case "\"
            Index = Index + 1
            Char = Mid(str, Index, 1)
            Select Case (Char)
               Case """", "\", "/", "'"
                  SB.Append Char
                  Index = Index + 1
               Case "b"
                  SB.Append vbBack
                  Index = Index + 1
               Case "f"
                  SB.Append vbFormFeed
                  Index = Index + 1
               Case "n"
                  SB.Append vbLf
                  Index = Index + 1
               Case "r"
                  SB.Append vbCr
                  Index = Index + 1
               Case "t"
                  SB.Append vbTab
                  Index = Index + 1
               Case "u"
                  Index = Index + 1
                  Code = Mid(str, Index, 4)
                  SB.Append ChrW(Val("&h" + Code))
                  Index = Index + 4
            End Select
         Case quote
            Index = Index + 1

            parseString = SB.toString
            Set SB = Nothing

            Exit Function

         Case Else
            SB.Append Char
            Index = Index + 1
      End Select
   Loop

   parseString = SB.toString
   Set SB = Nothing

End Function

Необработанные данные JSON с сайта: 

{"result":{"contains":[{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMSzG","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 1"},{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMTHk","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"},{"cptInMillis":1547531880000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25jMTN5","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"},{"cptInMillis":1547445480000,"containerType":"Case
","cpt":"REDACTED
PM","stackingFilter":"REDACTED","associationReason":"-","isEmpty":"-","resourceLabel":"csXP25k9Z5F","associatedUser":"REDACTED","cleanupAllowed":false,"isClosed":"-","containerId":"REDACTED","isForcedMove":"No","dwellTime":"REDACTED
: 2"}],"endToken":null,"startToken":"0"},"ok":true,"message":""}

Теперь, когда некоторые данные являются конфиденциальными, я отредактировал их, однако то, что мне действительно нужно, я оставил на месте.

Мне нужен объект "resourceLabel", который присутствует в данных JSON, которые я добавил здесь.

Теперь я получаю данные, однако они начинают выводиться со второго объекта «resourceLabel» вместо первого.

Что мне нужно: 

csXP25jMSzG  csXP25jMTHk  csXP25jMTN5  csXP25k9Z5F

Что я продолжаю получать: 

csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F

Теперь я мог просто упустить что-то очевидное, но я не уверен, почему это происходит. Если этот вопрос слишком сложный, слишком длинный или недостаточно объяснен, пожалуйста, дайте мне знать. Или, если Стек не является подходящим местом для такого рода вопросов, пожалуйста, направьте меня куда-нибудь еще.

Любая помощь будет принята с благодарностью. Спасибо.

1 Ответ

0 голосов
/ 13 января 2019

Если ваша главная цель - написать JSON-парсер, я бы предложил использовать существующий JSON-конвертер. Я использовал один из GitHub . С этим конвертером сравнительно легко получить resourceLabel. Вот один из способов: 

Option Explicit
Sub pj()
    Dim strJSON As String
    Dim JSON As Dictionary
    Dim dRES As Dictionary
    Dim oContains As Collection
    Dim V

strJSON = Cells(1, 1).Value2
Set JSON = parsejson(strJSON)
Set dRES = JSON("result")
Set oContains = dRES("contains")

For Each V In oContains
    Debug.Print V("resourceLabel")
Next V

End Sub

С вашей строкой JSON в A1, вывод: 

csXP25jMSzG
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...