VBA module to get access token for Upstox API

UpstoxAPI-VBA

Option Explicit

'Global Variables
'Adjust the below variables as required
Private Const ApiKey As String = "xxxxxxxxxxxxxxxxxxxxxxxxxxxyccLTA40xFY3vT"
Private Const ApiSecret As String = "xxxxxxxxxxxxxx4c0"
Private Const RedirectUrl As String = "https://howutrade.in"

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, _
                                                                               Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long

Public Sub Login()
    On Error GoTo ErrHandler:
    Dim LoginUrl As String
    LoginUrl = "https://api.upstox.com/index/dialog/authorize?apiKey=" & ApiKey & "&redirect_uri=" & RedirectUrl & "&response_type=code"
    Dim lSuccess As Long
    lSuccess = ShellExecute(0, "Open", LoginUrl)
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbCritical, "Error"
End Sub


Public Sub GetAccessToken()
    On Error GoTo ErrHandler:

    Dim AccessCode As String
    AccessCode = InputBox("Enter access code", "UpstoxAPI", "")
    If AccessCode = vbNullString Then
        MsgBox "Access Code Null", vbInformation, "Error"
        Exit Sub
    End If

    Dim AuthString As String
    AuthString = Base64Encode(ApiKey & ":" & ApiSecret)
    If AuthString = vbNullString Then
        MsgBox "Error getting Base64 encoding", vbInformation, "Error"
        Exit Sub
    End If

    Dim PostBody As String
    Dim HttpRequest As Object
    Dim Response As String
    Dim ResponseStatus As Integer

    Set HttpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpRequest.Open "POST", "https://api.upstox.com/index/oauth/token", False

    HttpRequest.setRequestHeader "Authorization", "Basic " & AuthString
    HttpRequest.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.3; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/60.0.3112.113 Safari/537.36"
    HttpRequest.setRequestHeader "Content-type", "application/json"
    HttpRequest.setRequestHeader "x-api-key", ApiKey

    PostBody = "{" & """" & "code" & """" & "  :  " & """" & AccessCode & """" & " , " & """" & "grant_type" & """" & "  :  " & """" & "authorization_code" & """" & " , " & """" & "redirect_uri" & """" & "  :  " & """" & RedirectUrl & """" & " }"
    HttpRequest.Send (PostBody)

    Response = HttpRequest.ResponseText
    ResponseStatus = HttpRequest.Status    'OK : 200

    If ResponseStatus = 200 Then
        MsgBox "Response: " & Response & vbCrLf & vbCrLf & "Code: " & ResponseStatus, 0 + 64, "AccessToken"
    End If

    If ResponseStatus <> 200 Then
        MsgBox "Response: " & Response & vbCrLf & vbCrLf & "Code: " & ResponseStatus, 0 + 48, "AccessToken"
    End If

    If Err.Number <> 0 Then
        MsgBox Err.Description, 0 + 16, "Error"
    End If
    Set HttpRequest = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbCritical, "Error"
End Sub

'Functions to get Base64Encode
'Credit : https://stackoverflow.com/questions/496751/base64-encode-string-in-vbscript
'Thanks to Patrick Cuff

Function Base64Encode(sText)
    On Error GoTo ErrHandler:
    Dim oXML, oNode

    Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
    Set oNode = oXML.CreateElement("base64")
    oNode.DataType = "bin.base64"
    oNode.nodeTypedValue = Stream_StringToBinary(sText)
    Base64Encode = oNode.Text
    Set oNode = Nothing
    Set oXML = Nothing
    Exit Function
ErrHandler:
    Base64Encode = ""
End Function

Function Stream_StringToBinary(Text)
    On Error GoTo ErrHandler:
    Const adTypeText = 2
    Const adTypeBinary = 1
    Dim BinaryStream    'As New Stream
    Set BinaryStream = CreateObject("ADODB.Stream")
    BinaryStream.Type = adTypeText
    BinaryStream.Charset = "us-ascii"
    BinaryStream.Open
    BinaryStream.WriteText Text
    BinaryStream.Position = 0
    BinaryStream.Type = adTypeBinary
    BinaryStream.Position = 0
    Stream_StringToBinary = BinaryStream.Read
    Set BinaryStream = Nothing
    Exit Function
ErrHandler:
    Stream_StringToBinary = Nothing
End Function