VBA Code to support OAuth2.0 Device Code Flow

gistfile1.txt

Sub deviceCodeFlow()
      Dim waiting As Boolean
      Dim responseData As String
      Dim responseData2 As String
      Dim device_code As String
      Dim user_code As String
      Dim verify_URL As String
      Dim postData1 As String
      Dim error_code As String
      Dim access_token As String
      Dim oauth_clientID As String
      Dim oauth_clientSecret As String
   
      waiting = True
      oauth_clientID="<CLIENT_ID>"
      oauth_clientSecret = "<CLIENT+SECRET>"
      postData1 = "response_type=device_code&scope=openid&client_id=" + oauth_clientID
    
'Console.WriteLine("Making initial OAuth call to acquire device code with POST data as: " + postData)
      
responseData = makeIDCSRequest("/oauth2/v1/device", postData1, False)

' Sample Response
'“device_code”: “236de6bc4eda4698a9e005xxxxxxxxx ","'“user_code”: “ABCDEFG”,
'“verification_uri”: “https://idcs-xxxxxx.identity.oraclecloud.com:443/ui/v1/device”,
'“expires_in”: 300
          
Set jsonOut = ParseJSON(responseData)
device_code = jsonOut("obj.device_code")
verify_URL = jsonOut("obj.verification_uri")
user_code = jsonOut("obj.user_code")
'Console.WriteLine(responseData)
'Get the device code and user code and redirect URL
'Redirect the user tot hU URL and enter the user code
       
Dim postData2 As String
postData2 = "grant_type=urn:ietf:params:oauth:grant-type:device_code&client_id=" + oauth_clientID + "&device_code=" + device_code + "&client_secret=" + oauth_clientSecret
      
'Tell the user to go to that URL
Console.WiteLine ("Open a browser, go to:")
Console.WiteLine (responseData.verification_uri)
Console.WiteLine ("and enter the code " +   responseData.user_code)
      
'Now we poll so that the user can enter the user code
Dim return_code As Integer
      
While waiting
   responseData2 = makeIDCSRequest("/oauth2/v1/token", postData2, False)
       
Set jsonOut = ParseJSON(responseData2)
error_code = jsonOut("obj.error")
access_token = jsonOut("obj.access_token")
return_code = StrComp(error_code, "authorization_pending")

If return_code = 0 Then
        Application.Wait (5000)
ElseIf Not (StrComp(access_token, "")) Then
        waiting = False
End If
Wend
End Sub

Public Function makeIDCSRequest(Uri As String, postData As String, ignore400 As Boolean) As String
   
   Dim objHTTP As Object
   Dim URL As String
   Dim host As String
   Dim idcs_url As String
   Dim user_agent As String
   Dim responseData As String
   Dim printRequest As String
    
  idcs_url = "https://idcs-xxxxxx.identity.oraclecloud.com"
  host = "idcs-xxxxxx.identity.oraclecloud.com"
  user_agent = "deviceTest"
   
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    'Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = idcs_url + Uri
     objHTTP.Open "POST", URL, False
     objHTTP.setRequestHeader "User-Agent", user_agent
     objHTTP.setRequestHeader "Host", host
     objHTTP.setRequestHeader "Content-Length", Len(postData)
     objHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
     objHTTP.setRequestHeader "Accept", "*/*"
     objHTTP.send postData
    responseData = objHTTP.responseText
    makeIDCSRequest = responseData
End Function