Adding Parameters to VBA HTTP Post Request - vba

Question

I want to request a token from a web service. It requires I make an HTTP "POST" request using an authorization code.
I need to include this code, among other parameters in my request.
Any detail I find online formats the request in Java as follows (all IDs are faked):
POST /services/oauth2/token HTTP/1.1
Host: "YourURL.com"
grant_type=authorization_code&code=aPrxsmIEeqM9PiQroGEWx1UiMQd95_5JUZ
VEhsOFhS8EVvbfYBBJli2W5fn3zbo.8hojaNW_1g%3D%3D&client_id=3MVG9lKcPoNI
NVBIPJjdw1J9LLM82HnFVVX19KY1uA5mu0QqEWhqKpoW3svG3XHrXDiCQjK1mdgAvhCs
cA9GE&client_secret=1955279925675241571&
redirect_uri=https%3A%2F%2Fwww.mysite.com%2Fcode_callback.jsp
How do I produce a request like this?
Below are the relevant components of my code:
Dim request As WinHttp.WinHttpRequest
Dim
client_id,
redirect_uri,
grant_type,
client_secret,
authcode,
result,
token_url,
As String
Sub testmod()
Set request = New WinHttp.WinHttpRequest
client_id = "MyClientID"
client_secret = "MyClientSecret"
grant_type = "authorization_code"
redirect_uri = "MyRedirectURI"
authcode = "MyAuthorizationCode"
token_url = "MyTokenURL" <--- No specified query string appended
With request
.Open method:="POST", Url:=token_url
''''Including POST Params with Send method''''
.Send ("{""code"":" & authcode &
",""grant_type"":authorization_code,""client_id"":" & client_id &
",""client_secret"":" & client_secret & ",""redirect_uri"":" &
redirect_uri & "}")
''''This returns error code 400 denoting a bad request''''
Debug.Print .StatusText
end with
end sub
Any idea why these parameters are causing this request to fail?

Answer 1

I don't know what API you are referring to, whereas there is a new API in which the oldest 'guide' is dated 'Mar' presumably 2019.
https://developer.tdameritrade.com/apis
https://developer.tdameritrade.com/guides
Wherein there is NO reference to the "&client_secret=" being needed !.
In the 'latest' API, you request the 'code' as follows directly into your browser. It is good got a very few minutes.
https://auth.tdameritrade.com/oauth?
client_id=XXXX#AMER.OAUTHAP&response_type=code&redirect_uri=https://192.168.0.100
The response appears in the browser's entry, not in the body, You have to decode the response to use the 'code'. The RefreshToken (90 days valid) & AccessToken (30 minutes valid) are used as the are returned in the ResponseText
To get the 90 day RefreshToken and the first AccessToken
This is VBA which calls Javascript.
Private Sub Get_RefreshToken() 'Good for 90 days, then needs a new 'code', see above, also get the first AccessToken which are good for 30 minutes
Dim code As String 'dcoded, not URL coded 'WAITS for the RESPONSE, NO callback
Dim shtSheetToWork As Worksheet
Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '<<== may NEED change
With shtSheetToWork
authorizationcode = .Range(3, "C") // dump into Excel and decode by rows JSON 'split'
Dim xmlhttp As Object
Dim scriptControl As Object
Dim Response, JsonObj As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Set scriptControl = CreateObject("MSScriptControl.ScriptControl")
scriptControl.Language = "JScript"
authUrl = "https://api.tdameritrade.com/v1/oauth2/token"
xmlhttp.Open "Post", authUrl, False
xmlhttp.Send "{grant_type: authorization_code, authorizationcode: ,access_type: offline, client_id: .UserId, redirect_uri: .URLredirect}"
Response = scriptControl.Eval(xmlhttp.responseText)
.Range(4, "C") = Response.refresh_token 'RefreshToken
xmlhttp.setRequestHeader "Authorization", Response.refresh_token
xmlhttp.Send
MsgBox (xmlhttp.responseText)
Select Case xmlhttp.Status
Case 200
Dim i As Integer
Dim strKey As String
Dim strVal As Variant
Dim JsonData As Variant
JsonObj = JsonDate.Parse(xmlhttp.responseText)
Cells(colstr, toprow - 1) = JsonObj
i = 1
Do While Trim(Cells(i, 1)) <> ""
Name = Split(Cells(i, 1).Text, ":")
If Name = "RefreshToken" Then .RefreshToken = Name: .nextRefreshToken = DateAdd("d", 90, Now)
If Name = "AccessToken" Then .AccessToken = Name: .nextAccessToken = DateAdd("m", 30, Now)
Case 400
MsgBox (" validation problem suthorization 'CODE' ")
Stop
Case 401
MsgBox (" Invalid credentials ")
Stop
Case 403
MsgBox (" caller doesn't have access to the account ")
Stop
Case 405
MsgBox (" Response without Allow Header")
Stop
Case 500
MsgBox (" unexpected server error ")
Stop
Case 503
MsgBox ("temporary problem responding, RETRYING !! ")
' WAIT A MINUTE AND RETRY
End Select
Set xmlhttp = Nothing
Set JsonObj = Nothing
End With
End Sub
Private Sub AccessToken() 'WAITS for the RESPONSE, NO callback
Dim code As String 'dcoded, not URL coded
Dim shtSheetToWork As Worksheet
Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '<<== may NEED change
With shtSheetToWork
Dim xmlhttp As Object
Dim scriptControl As Object
Dim Response, JsonObj As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Set scriptControl = CreateObject("MSScriptControl.ScriptControl")
scriptControl.Language = "JScript"
authUrl = "https://api.tdameritrade.com/v1/oauth2/token"
xmlhttp.Open "Post", authUrl, False
xmlhttp.Send "{grant_type: refresh_token, authorizationcode: .RefreshToken, access_type: , client_id: .MYUserId, redirect_uri: }"
Response = scriptControl.Eval(xmlhttp.responseText)
.AccessToken = Response.refresh_token
xmlhttp.setRequestHeader "Authorization", RefreshToken
xmlhttp.Send
'MsgBox (xmlhttp.responseText)
Select Case xmlhttp.Status
Case 200
Dim i As Integer
Private strKey As String
Private strVal As Variant
Private Data As Variant
JsonObj = Json.Parse(xmlhttp.responseText)
Cells(colstr, toprow - 1) = JsonObj
NextText = Cells(colstr, toprow - 1)
JsonObj = Nothing
i = 1
Do While Trim(Cells(i, 1)) <> ""
Name = Split(Cells(i, 1).Text, ":")
If Name = "RefreshToken" Then .RefreshToken = Name: .nextRefreshToken = DateAdd("d", 90, Now)
If Name = "AccessToken" Then .AccessToken = Name: .nextAccessToken = DateAdd("m", 30, Now)
Case 400
MsgBox (" validation problem suthorization 'CODE' ")
Stop
Case 401
MsgBox (" Invalid credentials ")
Stop
Case 403
MsgBox (" caller doesn't have access to the account ")
Stop
Case 405
MsgBox (" Response without Allow Header")
Stop
Case 500
MsgBox (" unexpected server error ")
Stop
Case 503
MsgBox ("temporary problem responding, RETRYING !! ")
' WAIT A MINUTE AND RETRY
End Select
Next i
Set xmlhttp = Nothing
End With
End Sub