MS Access 2016アプリケーションのGoogle oauth2

Question

MS Access 2016アプリケーションからGoogleカレンダーエントリを作成する必要があります。

これを行うには、OAuth2認証を実行する必要があります。今はちょっと切望しています。

私は多くのヒントを見つけることができるが、それは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) 

これらの関数は、これを動作させるために必要な設定を取得して設定します。それらをデータベーステーブルに格納したいかもしれませんが、どのようにするかはあなた次第であり、この回答の範囲外です。このソリューションに関与

設定は次のとおりです。

この解決のために

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) 

、我々が必要：（WebBrowser1という名前）WebBrowserコントロールと

• フォーム（名前のブラウザ）、
• HTTPリクエストを配置するクラス
• いくつかのツールを含むモジュール

クラスは、この（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 

このクラスは唯一の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_scopeで設定した値によって）特定のアクセスを要求するのOAuth2フローを経て1を取得することができます：

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 

を今、私は私ができるが、常に疑問があるだろうとして、このように明確にしようとしています。どうぞお気軽にお問い合わせください。私は彼らに喜んでお答えします。