Dev-MDW2
Reputation: 113
Parsing JSON Response Text Correctly
I have an issue in an Excel program I am creating. Put shortly, I have to pull JSON data from a website, parse it, and throw the response onto a worksheet for use later on. Whenever the code gets to the point where it is going to output the response text, the output is passing the first set of data I need from the response text. All data and examples below.
Code that creates and sends the HTTP request:
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 is the sheet the response text needs to output onto. The "(1 + i, d)" is there as I have a header on the sheet the output is going to that I don't want overridden.
Code that parses the response text that returns from the request:
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
The raw JSON data from the site:
{"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":""}
Now as some of the data is confidential, I have redacted it, however what I actually need I have left in place.
I need the "resourceLabel" object that is present in the JSON data I have added here.
Now I do get the data, however it starts outputting at the second "resourceLabel" object instead of the first.
What I need:
csXP25jMSzG csXP25jMTHk csXP25jMTN5 csXP25k9Z5F
What I keep getting:
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F
Now I could just be missing something obvious, but I am not sure why this keeps happening. If this question is too complicated, too long, or not explained enough, please let me know. Or if Stack is not the correct place for this sort of question, please direct me someplace else that would be.
Any help would be appreciated. Thank you.
Upvotes: 1
Views: 429
Answers (1)
Ron Rosenfeld
Reputation: 60249
Unless your prime goal is to write a JSON parser, I would suggest using an existing JSON converter. I have been using the one from GitHub. With that converter, it's relatively easy to get resourceLabel. Here's one way:
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
With your JSON string in A1, the output:
csXP25jMSzG
csXP25jMTHk
csXP25jMTN5
csXP25k9Z5F
Upvotes: 2