正确解析JSON响应文本

我正在创建的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

托盘库存是响应文本需要输出到的工作表。 “（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数据中的“resourceLabel”对象

现在我确实得到了数据，但是它从第二个“resourceLabel”对象开始输出，而不是第一个

我需要的是：

csXP25jMSzG  csXP25jMTHk  csXP25jMTN5  csXP25k9Z5F

我一直得到的是：

csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F

现在，我可能只是错过了一些显而易见的事情，但我不知道为什么这种情况一直发生。如果这个问题太复杂、太长或解释不够，请告诉我。或者，如果Stack不是此类问题的正确位置，请告诉我其他位置

任何帮助都将不胜感激。

---

谢谢。

除非您的主要目标是编写JSON解析器，否则我建议您使用现有的JSON转换器。我一直在使用来自的那个。使用该转换器，相对容易获得

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

使用

A1

中的JSON字符串，输出：

csXP25jMSzG
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F

---

有根据的猜测（当您错过第一个值时）：

Output.Item（“result”）.Item（“contains”）.Item（i）.Item（“resourceLabel”）

是零基的，这意味着第一个项是

。Item（0）

不是

。Item（1）

从哪里开始。将

项（i）

更改为

。Item（i-1）

无法测试您的代码。我在

parseBoolean

中得到了第一个错误，因为您没有包含它。但是在这个平台上有一个免费的JSON解析器。当然，如果您的目标主要是编写JSON解析器，那么这不是您想要的。但是，如果您的目标是解析这个特定的JSON，那么解析器会工作，并且它会返回您所需要的。@RonRosenfeld:似乎这是VBAJson祖先代码（Excel Rest）和OP missed，意外地提供了方法和代码源代码。您的代码缺少函数、类和变量声明。是的，我很笨。这是因为JSON响应文本基于零，而不是1。从1更改为100到0到99修复了我的问题。我想这是一个漫长的夜晚@ComputerVersteher：是的，这段代码是一个旧的JSON解析器的遗留代码，在过去的几个月里，我一直在相对成功地使用这段代码，尽管它已经开始显示出它的年龄，而且它确实偶尔会中断，即使是在同一个程序上提取相同的数据。