Public Function GetAccessToken() As String
Dim objBrowser As UserForm1
Dim objWinHttp As WinHttp.WinHttpRequest
Dim strURL As String
Dim strRequestBody As String
Dim strAuthorizationCode As String
Dim strFile As String
Dim strFolder As String
Dim strAccessToken As String
Dim objReg As RegistryUtility
Dim objJson As Scripting.Dictionary
Dim objFSO As Scripting.FileSystemObject
Dim objFile As Scripting.TextStream
Set objFSO = New Scripting.FileSystemObject
Set objReg = New RegistryUtility
Set objBrowser = New UserForm1
strFolder = Environ$("APPDATA") & "\" & ApplicationName
strFile = strFolder & "\client_id_" & ClientID & ".token-response"
strURL = "https://accounts.google.com/o/oauth2/v2/auth?scope=" & URLEncode(Join(Scope, " ")) & "&access_type=offline&include_granted_scopes=true&response_type=code&state=state_parameter_passthrough_value&redirect_uri=https%3A//localhost&client_id=" & ClientID
objBrowser.ClientID = ClientID
objBrowser.ApplicationName = ApplicationName
objBrowser.WebBrowser1.Navigate strURL
objBrowser.Show vbModal
If objReg.RegValueExists("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\" & ApplicationName & "\" & ClientID & "\AuthorizationCode") Then
strAuthorizationCode = objReg.ReadRegValue("HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\" & ApplicationName & "\" & ClientID & "\AuthorizationCode")
objReg.DeleteRegKey HKEY_CURRENT_USER, "Software\GoogleOAuth2VBA\" & ClientID & "\AuthorizationCode"
End If
If strAuthorizationCode <> vbNullString Then
strRequestBody = "code=" & strAuthorizationCode & "&" & _
"client_id=" & ClientID & "&" & _
"client_secret=" & ClientSecret & "&" & _
"redirect_uri=https%3A//localhost&" & _
"grant_type=authorization_code"
Set objWinHttp = New WinHttp.WinHttpRequest
With objWinHttp
.Open "POST", "https://oauth2.googleapis.com/token", False
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.SetRequestHeader "Accept", "application/json'"
.Send strRequestBody
If .Status = 200 Then
Set objJson = JsonConverter.ParseJson(.ResponseText)
strAccessToken = objJson.Item("access_token")
If strAccessToken <> vbNullString Then
GetAccessToken = strAccessToken
Set objFile = objFSO.CreateTextFile(strFile, True)
objFile.Write .ResponseText
objFile.Close
objReg.WriteRegValue "HKEY_CURRENT_USER\Software\GoogleOAuth2VBA\" & ApplicationName & "\" & ClientID & "\AccessTokenExpirationTime", CStr(DateAdd("s", CDbl(objJson.Item("expires_in")), Now)), REG_SZ
Else: Err.Raise vbObjectError + 2, , "Failed to get access code"
End If
End If
End With
Else
Err.Raise vbObjectError + 1, , "Failed to obtain the authorization code."
End If
End Function