VBA internet explorer object OnQuit activity is triggering when I click a button on the explorer window

Viewed 27

I have code which opens the login page to our oracle cloud infrastructure instance. However when I click on the single sign on button, it triggers the Internet Explore OnQuit activity which in turn in hampering the execution of the code. We're closely following Kyle Beachill's work (https://ramblings.mcpher.com/guests-articles-and-postings/oauth2-and-vba/). I basically want to capture the authcode in the URL before proceeding to get the token. What is happening now is after getting redirected to the single sign on page, I'm unable to capture the URL using the .LocationURL function.

code to open internet explorer:

Private Sub GetNewToken()


Set oIExplorer = New InternetExplorer

With oIExplorer
    .Navigate2 CreateAuthRequest()
    .AddressBar = True
    .MenuBar = True
    .Resizable = True
    .Visible = True
End With

Debug.Print ".LocationURL : " & oIExplorer.LocationURL
strAuthCode = ""
Do: DoEvents: Loop Until blnIeComplete 
Debug.Print ".LocationURL: " & GetURL
    
Debug.Print "strAuthCode: " & strAuthCode

'Debug.Print "second request"
'// Do we have an Authentication Code?
If Len(strAuthCode) = 0 Then
    Err.Raise vbObjectError + 2, _
        Description:="User cancelled Authentication"
End If

'// Now Get a new Token
If objXMLRequest Is Nothing Then Set objXMLRequest = New MSXML2.XMLHTTP60
Debug.Print "second request"
With objXMLRequest
    .Open "POST", strTokenUrl, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    .setRequestHeader "User-agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Postman/9.1.4 Chrome/87.0.4280.88 Electron/11.1.1 Safari/537.36"
    .send CreateTokenRequest()

    If .Status <> 200 Then
        '// Error getting OAuth2 token
        Err.Raise vbObjectError + .Status, _
            Description:="Failed to retrieve OAuth2 Token - " & .Status & ": " & .responseText
    End If
    Debug.Print ".Status: " & .Status
    Debug.Print ".StatusText: " & .StatusText
    
    '// Get the credentials from the response
    strToken = GetProp("access_token", .responseText)
    Debug.Print "strToken: " & strToken
    strRefreshToken = GetProp("refresh_token")
    Debug.Print "strRefreshToken: " & strRefreshToken
    dtExpiresWhen = DateAdd("s", CLng(GetProp("expires_in")), Now())

End With

'// Persist the Refresh key and expiry - the above should only ever need running once per application
SaveSetting "OracleAuth", "Tokens", "RefreshKey", strRefreshToken
SaveSetting "OracleAuth", "Tokens", "Token", strToken
SaveSetting "OracleAuth", "Tokens", "TokenExpiry", CStr(dtExpiresWhen)
End Sub

OnQuit:

Private Sub oIExplorer_OnQuit()
Debug.Print "Exit title url : " & oIExplorer.LocationURL
Debug.Print "geturl : " & GetURL
Debug.Print "END"
blnIeComplete = True
End Sub

TitleChange:

Private Sub oIExplorer_TitleChange(ByVal text As String)
Debug.Print "title change text : " & text
Debug.Print "title change url : " & oIExplorer.LocationURL
Debug.Print " get url : " & GetURL
If InStr(1, text, "Success") > 0 Then
    strAuthCode = oIExplorer.Document.getElementbyid("code").Value
    oIExplorer.Quit
ElseIf InStr(1, text, "Denied") > 0 Then
    oIExplorer.Quit
End If
End Sub
0 Answers
Related