向 VBA HTTP Post 请求添加参数

Question

我想从 Web 服务请求令牌。它要求我使用授权码发出 HTTP“POST”请求。

我需要在我的请求中包含此代码以及其他参数。

我在网上找到的任何细节都将 Java 中的请求格式化如下（所有 ID 都是伪造的）：

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

如何生成这样的请求？

以下是我的代码的相关组件：

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

知道为什么这些参数会导致此请求失败吗？

Answer 1

我不知道您指的是什么 API，但有一个新的 API，其中最古老的“指南”的日期大概是 2019 年 3 月。

https://developer.tdameritrade.com/apis 
https://developer.tdameritrade.com/guides 

其中没有提到需要“&client_secret=”！。 在“最新”API 中，您可以直接在浏览器中请求以下“代码”。几分钟就好了。

https://auth.tdameritrade.com/oauth?

client_id=XXXX@AMER.OAUTHAP&response_type=code&redirect_uri=https://192.168.0.100

响应出现在浏览器的条目中，而不是正文中，您必须对响应进行解码才能使用“代码”。 RefreshToken（90 天有效）和 AccessToken（30 分钟有效）用作在 ResponseText 中返回的

获取90天的RefreshToken和第一个AccessToken 这是调用 Javascript 的 VBA。

Private Sub Get_RefreshToken() '有效期为 90 天，然后需要一个新的'code'，见上文，同时获取第一个有效期为 30 分钟的 AccessToken Dim code As String 'dcoded，而不是 URL coded '等待响应，没有回调 将 shtSheetToWork 调暗为工作表 Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '

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' ")

停止 案例 401 MsgBox ("无效的凭据") 停止 案例 403 MsgBox ("调用者无权访问账户") 停止 案例 405 MsgBox ("没有允许标题的响应") 停止 案例 500 MsgBox ("意外的服务器错误") 停止 案例 503 MsgBox("临时问题响应，正在重试！！") ' 等一下然后重试

 End Select

Set xmlhttp = Nothing
Set JsonObj = Nothing
End With

结束子

Private Sub AccessToken() '等待响应，无回调 Dim code As String 'dcoded，而不是 URL 编码 将 shtSheetToWork 调暗为工作表 Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '

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' ")

停止 案例 401 MsgBox ("无效的凭据") 停止 案例 403 MsgBox ("调用者无权访问账户") 停止 案例 405 MsgBox ("没有允许标题的响应") 停止 案例 500 MsgBox ("意外的服务器错误") 停止 案例 503 MsgBox("临时问题响应，正在重试！！") ' 等一下然后重试

 End Select
            Next i

Set xmlhttp = Nothing

结束于 结束子