Refresh Token Using VBA

[RonAnderson]

Hi, I still don't have a full solution of using VBA to refresh the token but I have made some progress in that I connect to the server but it returns an error message "Authorization has been denied for this request.". I've checked all of the necessary credentials and they are correct. If there's anyone out there who has knowledge of both VBA and refresh token procedure, I'd be deeply grateful if you could look at the VBA code below to see if there's anything obviously wrong:-

Sub RefreshToken()

Dim hReq As Object, json As Dictionary

Dim sht As Worksheet

Dim strUrl As String

Set sht = Sheet1

strUrl = Cells(1, 5).value 'Variable text held in this cell

Set hReq = CreateObject("MSXML2.XMLHTTP")

    With hReq

        .Open "GET", strUrl, False

        .SetRequestHeader "Authorization", "Basic Base64Encode"

        .SetRequestHeader "Content_Type", "application/x-www-form-urlencoded"

        .SetRequestHeader "grant_type", "refresh_token"

        .SetRequestHeader "refresh_token", “MyRefreshToken”

       .Send 'CreateRefreshRequest()

    End With

Response = hReq.ResponseText

‘//Do other things here

End Sub

[DrSimi]

Hi Ron,

 

I have not tested this very much as I do not work with VBA a lot, but below is sample code you may use and modify for your needs. This is based on posts such as

VBA API Convert JSON response & place into Excel Sheet - Stack Overflow

Function GetToken is self-explanatory, as it gets the access Token using your REST API Token URL. It is using 3rd party open source libraries to parse the JSON response, so you need to add those to Office first. See VBA-tools/VBA-JSON: JSON conversion and parsing for VBA (github.com)

Function SendRequest is very basic and lacks a body for parameters at the moment (you may want to add that), but works. It will try to send a request with the method provided (GET, PUT, etc) and on the URL described. Since we are not providing the auth token when calling it, it will fail once and call GetToken for it. You may want to change this to reduce API call usage/errors.

 

Global AuthToken As String
Public limiter As Integer

Public Function GetToken() As String
Dim objrequest As MSXML2.XMLHTTP60
Dim strUrl As String
Dim blnAsync As Boolean
Dim strResponse As String
Dim clientID As String
Dim clientSecret As String
Dim authbody As String
Dim TokenJson As Dictionary
Dim JsonValues As Variant

Set objrequest = New MSXML2.XMLHTTP60
strUrl = "https://********.caspio.com/oauth/token"
clientID = "&client_id=yourclientid"
clientSecret = "&client_secret=yourclientsecret"
authbody = "grant_type=client_credentials" & clientID & clientSecret
blnAsync = False

With objrequest
    .Open "POST", strUrl, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    '.setRequestHeader "Authorization", "Basic " & TextBase64Encode(bas, "us-ascii")
    '.setRequestHeader "Access-Control-Allow-Methods", "POST"
    .send authbody
    'spin wheels whilst waiting for response
    While objrequest.ReadyState <> 4
'While request is completed, do something
    Wend
    If objrequest.ReadyState = 4 Then
    If objrequest.Status = 200 Then
        strResponse = .responseText
    ElseIf objrequest.Status = 401 Then
        strResponse = "Unauthorized API"
    End If
    strResponse = .responseText
    Set TokenJson = JsonConverter.ParseJson(strResponse)
    End If
End With
AuthToken = TokenJson("access_token")
Debug.Print AuthToken

End Function


Public Function SendRequest(Op As String, strUrl As String) As String
Start:
Dim objrequest1 As MSXML2.XMLHTTP60
Dim blnAsync As Boolean
Dim strResponse As String
Dim AuthStr As String
Dim retry As String

Set objrequest1 = New MSXML2.XMLHTTP60
blnAsync = False
AuthStr = "Bearer " & AuthToken
Debug.Print "TokenCheck"
Debug.Print AuthToken
Debug.Print AuthStr

With objrequest1
    .Open Op, strUrl, False
    .setRequestHeader "Authorization", "Bearer " & AuthToken
    'send "q=where..."
    .send
    'spin wheels whilst waiting for response
    While objrequest1.ReadyState <> 4
'While request is completed, do something
    Wend
    If objrequest1.ReadyState = 4 Then
        If objrequest1.Status = 200 Then
            strResponse = .responseText
		'If response is 401 (unauthorized), call GetToken, retry up to 5 times to avoid rate limit errors or excessive calls
        ElseIf objrequest1.Status = 401 And limiter <= 5 Then
        Debug.Print "401...Getting Token"
            retry = GetToken()
            limiter = limiter + 1
            GoTo Start
        End If
    strResponse = .responseText
    End If
End With

Debug.Print strResponse

End Function

Sub CallAPI()
Dim tryAPI As String
tryAPI = SendRequest("GET", "https://********.caspio.com/rest/v2/tables/yourtable/records")
End Sub

 

 

 

[RonAnderson]

Hi @DrSimi, I really appreciate your response. I need to familiarise myself with the layout and will get back to you with my results.