Google 来自 MS Access 2016 应用程序的 oauth2

Question

我需要从 MS Access 2016 应用程序创建 Google 日历项。

为了能够做到这一点，我需要执行 OAuth2 身份验证，我现在有点绝望。

我可以找到很多提示，但它 none 适用于 MS Access（好吧，有些适用于 MS Access，但它们使用过时的身份验证方法，因此不是很有用）

我真的是第一个尝试这个的人吗？还是有人比我先走这条路并且愿意分享他或她的经验和代码？

非常感谢！

Answer 1

首先，有关 Google 的 oAuth2 的信息以及获取您的 client_id 和 client_secret，请看这里：https://developers.google.com/identity/protocols/OAuth2

好的，开始吧，这就是我构建的。

首先让我们讨论先决条件。有 2 个功能我不会在这里描述，因为它们往往非常个人化。这些函数是：

Public Function GetDBSetting(field as string) as string
Public Sub SetSetting(field as string, value as string)

这些函数获取并设置此功能正常工作所需的设置。您可能希望将它们存储在数据库中 table，但是如何执行完全取决于您，并且不在本答案的范围内。

本方案涉及的设置有：

oauth2_client_id       (you get this from google)
oauth2_client_secret   (this is given to you by google as well)
oauth2_scope           (just pick the scope you need)
oauth2_access_token    (this we collect)
oauth2_refresh_token   (this we collect)
oauth2_token_type      (this we collect)

对于此解决方案，我们需要：

带有 WebBrowser 控件（名为 WebBrowser1）的表单（名为 Browser），
a class 放置 HTTP 请求
带有一些工具的模块

class 看起来像这样（将 class 保存为 HTTP_Response）：

Option Compare Database
Option Explicit

' A very simple class to send HTTP requests and receive the resulting body

' These variables hold the results
Public Status As Long
Public StatusText As String
Public responseText As String

' This sub simply sends the request and collects the results

' Headers should be an array of strings with the following format: headername:value
Public Sub sendHTTP(URL As String, Optional METHOD As String = "POST", Optional CONTENT As String = "text/plain", Optional BODY As String = "", Optional addAuth As Boolean = False, Optional Headers As Variant)

    Dim Http As MSXML2.XMLHTTP60
    Dim hdrLine As Variant
    Dim hdrarr As Variant

    Set Http = New MSXML2.XMLHTTP60

    With Http
        Call .Open(METHOD, URL)
        If CONTENT <> "" Then Call .setRequestHeader("Content-Type", CONTENT)
        If addAuth Then Call .setRequestHeader("Authorization", GetDBSetting("oauth2_token_type") & " " & GetDBSetting("oauth2_access_token"))
        If IsArray(Headers) Then
            For Each hdrLine In Headers
                hdrarr = Split(CStr(hdrLine), ":")
                Call .setRequestHeader(hdrarr(0), hdrarr(1))
            Next
        End If

        Call .send(BODY)

        Status = .Status
        StatusText = .StatusText
        responseText = .responseText
    End With

End Sub

此class仅用于使发送HTTP请求和接收结果更容易。没什么好看的。

模块如下所示：

Option Compare Database
Option Explicit

' A function that checks if the known token is still valid and tries to request a refresh token if it is not
Public Function checkToken() As Boolean

    Dim resTxt As New HTTP_Response

    Call resTxt.sendHTTP("https://www.googleapis.com/oauth2/v1/tokeninfo?access_token=" & GetDBSetting("oauth2_access_token"))
    If resTxt.Status = 200 Then
        checkToken = True
    Else
        checkToken = refreshToken
    End If

End Function

' A function that requests a refresh token
Public Function refreshToken() As Boolean

    Dim authres() As String
    Dim resTxt As New HTTP_Response
    Dim svarbody As String
    Dim aCnt As Integer

    svarbody = "client_secret=" & GetDBSetting("oauth2_client_secret") & "&" & _
        "grant_type=refresh_token&" & _
        "refresh_token=" & GetDBSetting("oauth2_refresh_token") & "&" & _
        "client_id=" & GetDBSetting("oauth2_client_id")

    Call resTxt.sendHTTP("https://www.googleapis.com/oauth2/v4/token", , "application/x-www-form-urlencoded", svarbody, False)
    If resTxt.Status = 200 Then
        authres = Split(resTxt.responseText, """")

        aCnt = 0
        While aCnt < UBound(authres)
            aCnt = aCnt + 1
            If authres(aCnt) = "access_token" Then Call SetSetting("oauth2_access_token", authres(aCnt + 2))
            If authres(aCnt) = "token_type" Then Call SetSetting("oauth2_token_type", authres(aCnt + 2))
            If authres(aCnt) = "refresh_token_" Then Call SetSetting("oauth2_refresh_token", authres(aCnt + 2))
        Wend
        refreshToken = True
    Else
        refreshToken = False
    End If
End Function

' A sub to revoke a known token
Public Sub revokeToken()

    Dim resTxt As New HTTP_Response

    if checkToken() Then Call resTxt.sendHTTP("https://accounts.google.com/o/oauth2/revoke?token=" & GetDBSetting("oauth2_access_token"))

End Sub

您可以使用这些功能来确保您拥有有效的 access_token。

如果您没有有效的 access_token，您可以通过请求特定访问权限的 oAuth2 流程（通过您在 oauth2_scope 中设置的值）打开使用命令形成：

Call DoCmd.OpenForm("Browser", acDialog)

表单 VBA 代码如下所示：

Option Compare Database

Private Enum BrowserNavigationFlags
    navOpenInNewWindow = 1      ' Open the resource or file in a new window.
    navNoHistory = 2            ' Do not add the resource or file to the history list. The new page replaces the current page in the list.
    navNoReadFromCache = 4      ' Do not read from the disk cache for this navigation.
    navNoWriteToCache = 8       ' Do not write the results of this navigation to the disk cache.
End Enum

Private Sub Form_Load()

    Call Me.WebBrowser1.Object.Navigate2("about:blank", navNoReadFromCache)
    Call startOauth2
End Sub

Private Sub WebBrowser1_NavigateError(ByVal pDisp As Object, URL As Variant, TargetFrameName As Variant, StatusCode As Variant, Cancel As Boolean)

    ' Due to the redirect URL pointing to Localhost and we don't have a webserver running at localhost (Just make sure we don't!)
    ' The browser triggers the NavigateError event when it receives the URL for localhost
    ' We can now read the URL and extract the received code to request a token

    Dim retCode, getAccessToken As String
    Dim authres() As String
    Dim aCnt As Long
    Dim resTxt As New HTTP_Response

    ' Extract the code from the URL
    retCode = Right(URL, Len(URL) - (InStr(1, URL, "&code=") + 5))
    ' Construct the Body to request a access token and a refresh token
    getAccessToken = "code=" & retCode & "&" & _
        "client_id=" & GetDBSetting("oauth2_client_id") & "&" & _
        "client_secret=" & GetDBSetting("oauth2_client_secret") & "&" & _
        "redirect_uri=http%3A%2F%2Flocalhost&" & _
        "grant_type=authorization_code"

    ' Send the request
    Call resTxt.sendHTTP("https://www.googleapis.com/oauth2/v4/token", "POST", "application/x-www-form-urlencoded", getAccessToken)
    ' And receive the tokens
    authres = Split(resTxt.responseText, """")

    ' Now extract the tokens from the received body
    ' I know this can be done differently with a nice JSON class
    aCnt = 0
    While aCnt < UBound(authres)
        aCnt = aCnt + 1
        If authres(aCnt) = "access_token" Then Call SetSetting("oauth2_access_token", authres(aCnt + 2))
        If authres(aCnt) = "token_type" Then Call SetSetting("oauth2_token_type", authres(aCnt + 2))
        If authres(aCnt) = "refresh_token_" Then Call SetSetting("oauth2_refresh_token", authres(aCnt + 2))
    Wend

    ' And we are done
    Set resTxt = Nothing
    Call DoCmd.Close(acForm, "Browser")
End Sub

Private Sub startOauth2()

    ' Here we start stage 1 of the oAuth2 process
    Dim svarbody As String
    Dim resTxt As New HTTP_Response

    ' First we create a body to request access
    svarbody = "client_id=" & GetDBSetting("oauth2_client_id") & "&" & _
        "state=Anything_can_come_here_we_dont_use_it&" & _
        "redirect_uri=http%3A%2F%2Flocalhost&" & _
        "scope=" & GetDBSetting("oauth2_scope") & "&" & _
        "response_type=code&" & _
        "access_type=offline"

    ' Send the request
    Call resTxt.sendHTTP("https://accounts.google.com/o/oauth2/v2/auth", "POST", "application/x-www-form-urlencoded", svarbody)
    ' And write the result to the WebBrowser control on the form
    Call Me.WebBrowser1.Object.Document.Write(resTxt.responseText)

    Set resTxt = Nothing

End Sub

现在，我已尽我所能将这一点说清楚，但总会有问题。请不要犹豫，我会很乐意回答他们。

Google 来自 MS Access 2016 应用程序的 oauth2

Google oauth2 from an MS Access 2016 application

ms-access

google-calendar-api

oauth-2.0