向VBA HTTP发布请求添加参数 [英] Adding Parameters to VBA HTTP Post Request

查看：195
本文介绍了向VBA HTTP发布请求添加参数的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

让我在开始我的帖子前指出我对利用VBA的这一方面还很陌生.

我有兴趣从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

结束子

关于这些参数为何导致此请求失败的任何想法?任何见解都将不胜感激！

解决方案

我不知道您指的是什么API，但是有一个新的API，其中最早的指南"的日期大概是"Mar"，大概是2019年. 

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天，然后需要一个新的'代码'，请参见上文，并获得第一个有效时间为30分钟的AccessToken 暗码为String'dcoded，而非URL编码'WAITS的RESPONSE，没有回调 昏暗的shtSheetToWork作为工作表 设置shtSheetToWork = ActiveWorkbook.Sheets("AUTH")'<&===可能需要更改 使用shtSheetToWork authorizationcode = .Range(3，"C")//转储到Excel中并按行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' ")

停止 案例401 MsgBox(无效凭据") 停止 案例403 MsgBox(呼叫者无权访问该帐户") 停止 案例405 MsgBox(没有允许标题的响应") 停止 案例500 MsgBox(服务器意外错误") 停止 案例503 MsgBox(临时问题正在响应，正在重试！") '等待一分钟并重试

 End Select

Set xmlhttp = Nothing
Set JsonObj = Nothing
End With

结束子

Private Sub AccessToken()'等待响应，没有回调 暗码为String编码，而非URL编码 昏暗的shtSheetToWork作为工作表 设置shtSheetToWork = ActiveWorkbook.Sheets("AUTH")'<&===可能需要更改 使用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' ")

停止 案例401 MsgBox(无效凭据") 停止 案例403 MsgBox(呼叫者无权访问该帐户") 停止 案例405 MsgBox(没有允许标题的响应") 停止 案例500 MsgBox(服务器意外错误") 停止 案例503 MsgBox(临时问题正在响应，正在重试！") '等待一分钟并重试

 End Select
            Next i

Set xmlhttp = Nothing

结尾为 结束

Let me preface my post by noting that I am quite new to leveraging this side of VBA.

I am interested in requesting a token from a web service which requires I make an HTTP "POST" request using an authorization code I have personally. I am needing to include this code, among other parameters in my request, but am struggling to do so successfully. Any detail I find online formats their 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

Producing a request like this has been a real struggle personally. 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 ideas as to why these parameters are causing this request to fail? Any insight is greatly appreciated!

解决方案

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

这篇关于向VBA HTTP发布请求添加参数的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
其他开发最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆