AccessでGoogle認証とファイルのダウンロード

現在、VBAで業務用アプリケーションを作成していますが、アップデータの配布に於いてイントラネット内に配置ですと、外部ではアップデートが出来ないことになります。かといって、VPNの設定などをして入れるようにするというのも考えもの。ということで、アップデータの配布にG SuiteのGoogle Driveを使えないか？

ということで、VBAにてGoogle認証をし、Drive APIを叩いてファイルをダウンロードする手段を考えました。Client IDや
Client Secretがあっても今回の手法の場合、組織内のアカウントでない場合、認証が通らずダウンロードが出来ません。また、この手法の場合、ファイルへのアクセス権が全くなくとも、ファイルオーナーの自分だけはダウンロードが可能になったりします。とても便利。今回はAccess VBAにて作成しています。

1 今回使用するファイルや資料
2 新方式が登場しました
3 IE11を使わない認証対応版
4 事前準備
- 4.1 プロジェクトの作成
- 4.2 ダウンロードファイルの準備
5 ソースコード
- 5.1 OAuth認証の為のコード
- 5.2 ファイルのダウンロードの為のコード
6 実行と結果
7 関連リンク

今回使用するファイルや資料

新方式が登場しました

IE11の廃止に伴い、SeleniumやNode.jsやらといった手段を使わず、またPuppeteerと同様の手法（CDPを叩く）でVBAとEdge/ChromeのみでOAuth2.0認証する手段が登場しました。スクレイピングも可能になっています。以下のエントリーを参考にしてみてください。この手法は最も制限が無く、もっともすぐれた選択肢になると思います。

VBAでOAuth2.0認証 - 新方式を試してみた

IE11を使わない認証対応版

IE11廃止に伴い、本ページの認証部分については、IE11を使わない認証方法を利用する必要があります。この部分について、対応版を作成しました。以下のエントリーを参考に、Puppeteerを使った認証を利用すると、2022年6月以降も、VBAでGoogle API認証が可能になります。

VBAからGoogle APIを叩いてみる – IE11廃止対応版

事前準備

プロジェクトの作成

今回は、Google Apps Scriptは使用しません。が、Google Drive APIは必要になります。そのため、Google Cloud PlatformにてDrive APIの有効化とClient IDおよびClient Secretが必要になります。以下の手順でプロジェクトを作成します。

Google Cloud Platformにアクセスする
ページの上部、Cloud Platformの文字の横にある▼をクリックする
出てきたダイアログの右上、「新しいプロジェクト」をクリックする
プロジェクト名を設定し、作成ボタンをクリックします。
左サイドバーのAPIとサービスをクリックします。
検索にて、Drive APIを検索し、有効にするをクリック。
左サイドバーの認証情報をクリックします。
認証情報を作成をクリックします。
OAuthクライアントIDを選択します。
「OAuth クライアント ID を作成するには、まず同意画面でサービス名を設定する必要があります。」と出るので、同意画面を設定をクリック。
OAuthの同意画面では、アプリケーションの種類を今回は「内部」にしておきます。これで組織外のユーザは認証出来ません。
アプリケーション名を適当に設定し、保存をクリック。
次の画面では、アプリケーションの種類を選びます。ここでは、「その他」を選択します。名前は適当につけて、作成をクリックします。
ここで、OAuthクライアントIDとシークレットが出るので控えておきます。

図：プロジェクトを作成しましょう。

図：組織内のユーザに限定しちゃいましょう。

図：重要なコードなので他人に開示したりしちゃだめです。

ダウンロードファイルの準備

事前にGoogle Driveにファイルをアップロードしておきます。ファイルは今回G Suite内のユーザ共有か？自分だけがアクセスできる状態にしておきます。前者であれば「リンクを知ってるxxxの全員が閲覧可」や後者であれば、「オフ - 特定のユーザだけがアクセス出来ます」の状態にしておきます。

また、アップロードが完了したら、ファイルのIDを控えておきます。ファイルIDはURLの中で、/d/の後ろから/viewの前までの文字列。これが今回VBAからダウンロードするファイルとなります。

例：https://drive.google.com/file/d/1pB38TVRqX7BnxU294RpTMhSsFkXBkwEx/view?usp=sharing

図：ファイルは限定公開の状態にしておきます。

ソースコード

OAuth認証の為のコード

Option Explicit
'--------------------------------------------------
'クライアントIDやシークレット等
'--------------------------------------------------
Public Const client_id As Variant = "ここにクライアントIDを入れてください。"
Public Const client_secret As Variant = "ここにクライアントシークレットを入れてください。"

'--------------------------------------------------
'認証用文字列、スコープ、リダイレクトURI等
'--------------------------------------------------
Private Const response_type As String = "code"
Private Const redirect_uri As String = "urn:ietf:wg:oauth:2.0:oob"
Private Const grant_type As String = "authorization_code"
Private Const scope As String = "profile email https://www.googleapis.com/auth/drive"  '半角スペースで区切る
Private Const oauthurl As String = "https://accounts.google.com/o/oauth2/auth?"
Private Const tokenurl As String = "https://www.googleapis.com/oauth2/v4/token"
Private Const reftokenurl As String = "https://accounts.google.com/o/oauth2/token"
Private Const tokeninfo As String = "https://www.googleapis.com/oauth2/v3/tokeninfo?access_token="

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)

'認証の実行とAccess_Token等の保存
Public Function Authgoogle()
    Dim auth_code As String
    Dim tokenget As String
    Dim ret As String
   
    'serverAuthCodeを取得
    auth_code = GetAuthorizationCode()
    
    'Access_Tokenを取得
    tokenget = GetAccessToken(auth_code)
    
    '取得結果を表示
    If tokenget = True Then
      MsgBox "認証が完了しました。"
    Else
      MsgBox "認証に失敗しました。"
    End If
    
End Function

'認証用serverAuthCodeの取得
Public Function GetAuthorizationCode() As String
  '各種変数の宣言
  Dim ie As Object
  Dim url As String
  Dim iptCode As Object
  Dim auth_code As String
  
  Const READYSTATE_COMPLETE = 4
   
  '初期化
  Set ie = Nothing
  Set iptCode = Nothing
  auth_code = ""

  'OAuth認証用URLの組み立て
  url = oauthurl & _
        "client_id=" & client_id & "&" & _
        "response_type=" & response_type & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "scope=" & EncodeURL(scope)
 
  'IEを起動し認証URLを開く
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Visible = True
    .AddressBar = False
    .MenuBar = False
    .StatusBar = False
    .Toolbar = False
    .Width = 600
    .Height = 480
    .Navigate url
    
    '認証が実行されるまで待機
    While .Busy Or _
          .ReadyState <> READYSTATE_COMPLETE Or _
          InStr(LCase(.LocationURL), "https://accounts.google.com/o/oauth2/approval") < 1
      DoEvents
    Wend
    
    '10秒間sleepさせる（Windows10対策）
    Sleep 7000
    
    
    '認証が実行されたらserverAuthCodeを取得
    On Error Resume Next
    auth_code = .Document.getElementsByClassName("qBHUIf")(0).value
    
    'ログアウトさせる
    '.Navigate "https://accounts.google.com/o/logout"
    While .Busy Or .ReadyState <> READYSTATE_COMPLETE
      DoEvents
    Wend
    .Quit
  End With
  
  '取得したserverAuthCodeを返す
  GetAuthorizationCode = auth_code

End Function

'Access_Token他を取得するコード
Private Function GetAccessToken(ByVal auth_code As String) As Boolean
  Dim access_token As String
  Dim Json As String
  Dim dat As Variant
  Dim jsonstr As Object
  
  Dim SQL As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Set db = CurrentDb()
  Set rs = db.OpenRecordset("setting", dbOpenDynaset)
  
  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

  'Access_Token取得用POST文字列の組み立て
  dat = "code=" & auth_code & "&" & _
        "client_id=" & client_id & "&" & _
        "client_secret=" & client_secret & "&" & _
        "redirect_uri=" & redirect_uri & "&" & _
        "grant_type=" & grant_type & "&" & _
        "&access_type=offline"
        
  'POST通信でAccess Token等をリクエスト
  With CreateObject("WinHttp.WinHttpRequest.5.1")
    .Open "POST", tokenurl, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .send dat
    If .status = 200 Then
      '返ってきたJSON文字列を取得
      Json = .ResponseText
      If Len(Trim(Json)) > 0 Then
        'JSON文字列より各種値を取得・保存
        'パース関数でJSONオブジェクトを取得
        Set jsn = doc.JsonParse(Json)

        'tokenをsettingテーブルに保存
        With rs
          .FindFirst "ID=1"
          .Edit
          !accesstoken = jsn.access_token
          !refreshtoken = jsn.refresh_token
          .Update
        End With

        rs.Close: Set rs = Nothing
        db.Close: Set db = Nothing
        
        GetAccessToken = True
      Else
        GetAccessToken = False
      End If
    Else
      GetAccessToken = False
    End If
  End With
End Function

'Access_Tokenをチェックし、refresh_tokenで新しいAccess_Tokenを取得する関数
Public Function checkAccessToken() As Boolean
  Dim access_token As String
  Dim refresh_token As String
  Dim Json As String
  Dim dat As Variant
  Dim jsonstr As Object
  Dim ngflag As Boolean
  Dim xmlHttp  As Object
  Dim url As String
  Dim strRes As String
  Dim status As String
  Dim expirein As Integer
  
  Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
   
  'DB接続用
  Dim SQL As String
  Dim db As DAO.Database
  Dim rs As DAO.Recordset
  Set db = CurrentDb()
  Set rs = db.OpenRecordset("setting", dbOpenDynaset)
  
  'JSONをパースする用の変数
  Dim doc, jsn
  'HTMLDocumentを取得
  Set doc = CreateObject("HtmlFile")
  'scriptタグを追加
  doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
  
  '取得済みAccess_Token類を呼び出す
  With rs
    .FindFirst "ID=1"
    access_token = !accesstoken
    refresh_token = !refreshtoken
  End With

  'Access_Tokenを'tokeninfoでexpireしてるかチェック
  url = tokeninfo & access_token
  With xmlHttp
    .Open "GET", url, False
    .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
    .send
    strRes = .ResponseText
    status = .status
  End With

  If status = 200 Then
    'expireしていなければ200が返ってくる
    ngflag = False
    
    'expires_inが60以下ならrefreshしてしまう
    Set jsn = doc.JsonParse(strRes)
    expirein = CInt(jsn.expires_in)
    
    If expirein <= 60 Then
      ngflag = True
    Else
      ngflag = False
    End If
    
  Else
    'expireしてると400が返ってくる
    ngflag = True
  End If
    
  'ngflagをもとにrefresh_Tokenを使って新しいtokenを取得する
  'reftokenurlを使用する
  If ngflag = True Then
    'refresh_TokenでPOSTするパラメータを組み立て
    dat = "client_id=" & client_id & _
        "&client_secret=" & client_secret & _
        "&grant_type=refresh_token" & _
        "&refresh_token=" & refresh_token

    'POSTで新しいAccess_Tokenを取得する
    With xmlHttp
      .Open "POST", reftokenurl, False
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded;charset=UTF-8"
      .send (dat)
      strRes = .ResponseText
      status = .status
    End With

    '新しく取得したAccess_Tokenを格納する
    If status = 200 Then
        'HTMLDocumentを取得
        Set doc = CreateObject("HtmlFile")
        'scriptタグを追加
        doc.Write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
        
        Set jsn = doc.JsonParse(strRes)
        access_token = jsn.access_token
        
        With rs
          .FindFirst "ID=1"
          .Edit
          !accesstoken = access_token
          .Update
        End With

        ngflag = False
    Else
        ngflag = True
        MsgBox "再認証が必要です。再認証後再度実行してください。"
        Call Authgoogle
    End If

  End If

  '終了処理
  Set xmlHttp = Nothing
  rs.Close: Set rs = Nothing
  db.Close: Set db = Nothing
  
  '値を返す
  checkAccessToken = ngflag

End Function
'URLエンコードする為の関数
Public Function EncodeURL(ByVal str As String) As String
    
    #If Win64 Then
        '64bitの場合のコード
        Dim s As String, com As String, ret As String
        Dim ScriptFilePath As String, ExeFilePath As String
         
        ret = "" '初期化
         
        'スクリプト用コード設定
        s = "Option Explicit" & vbCrLf
        s = s & vbCrLf
        s = s & "Dim Args, ret" & vbCrLf
        s = s & vbCrLf
        s = s & "Set Args = WScript.Arguments" & vbCrLf
        s = s & "If Args.Count < 1 Then WScript.Quit" & vbCrLf
        s = s & "With CreateObject(""ScriptControl"")" & vbCrLf
        s = s & "  .Language = ""JScript""" & vbCrLf
        s = s & "  ret = .CodeObject.encodeURIComponent(Args(0))" & vbCrLf
        s = s & "End With" & vbCrLf
        s = s & "Set Args = Nothing" & vbCrLf
        s = s & "WScript.Echo ret"
         
        ScriptFilePath = VBA.Environ$("TEMP") & "\enc.vbs"
        With CreateObject("Scripting.FileSystemObject")
          With .CreateTextFile(ScriptFilePath, True)
            .Write s
            .Close
          End With
          If .FileExists(ScriptFilePath) Then
            ExeFilePath = .GetSpecialFolder(0).Path & "\SysWOW64\cscript.exe"
            If .FileExists(ExeFilePath) Then
              com = ExeFilePath & " //Nologo """ & ScriptFilePath & """ """ & str & """"
              ret = CreateObject("WScript.Shell").Exec(com).StdOut.ReadAll
            End If
            .DeleteFile ScriptFilePath
          End If
        End With
        EncodeURL = ret
    #Else
        '32bitの場合のコード
        Dim script As Object
        Dim js As Object
        
        Set script = CreateObject("ScriptControl")
        script.language = "JavaScript"
        Set js = script.CodeObject
        EncodeURL = js.encodeURIComponent(str)
    #End If
    
End Function

Authgoogleを実行することで、認証が実行されます。
続けて、GetAutherizationCodeが実行されて、IEが立ち上がりログインを要求してきます。
sleepを入れている理由は、さっと閉じてしまうと認証結果のコードを取りそこねるのを防ぐためです。
checkAccessTokenは、Access Tokenがexpireしていないかチェックを行い、expireしている場合には、refresh Tokenを使って自動でAccess Tokenを取り直しています。
取得したAccess TokenおよびRefresh Tokenはsettingテーブルに格納しています。
2019年1月1日より、ブラウザ上で表示されるAuthrization Codeの取得の為の仕様が変更になっているため、旧来のgetElementById(“code”)でelement指定しても取れません。auth_code = .Document.getElementsByClassName(“qBHUIf”)(0).valueといった形でClassName指定で取得するようにしています。

ファイルのダウンロードの為のコード

Option Compare Database
'ファイルダウンロード関数（カレントディレクトリにダウンロード）
Public Function getFileDownload()
    'DB接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("setting", dbOpenDynaset)
    
    'バイナリファイル生成用
    Dim FileData() As Byte
    Dim FileNum As Long
    
    'ファイルのIDを指定し、URLを組み立てる
    Dim fileid As Variant
    fileid = "ここにファイルのIDを入れてください"
    Dim downurl As String
    downurl = "https://drive.google.com/uc?export=download&id=" & fileid

    'Access_Tokenのexpireチェック
    Dim ret As Variant
    Dim access_token As String
    ret = checkAccessToken()
    
    If ret = False Then
      '取得済みAccess_Token類を呼び出す
      With rs
        .FindFirst "ID=1"
        access_token = !accesstoken
      End With
    Else
      'エラーメッセージを出して、再認証をする
      MsgBox "再認証が必要です。"
      Call Authgoogle
      Exit Function
    End If

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", downurl, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send
        
        '返ってきた値をもとにデータを処理
        Select Case .status
            Case 200
                'レスポンスヘッダを取得
                Debug.Print .GetAllResponseHeaders()
                
                'バイナリデータを取得
                FileData = .responseBody
                
                'ファイル名を取得する
                tempheader = .GetResponseHeader("Content-Disposition")
                disposition = DEcodeURLMSHTML(Mid(tempheader, InStr(tempheader, "filename*=UTF-8''") + 17))
                
                'ファイルパス組み立て
                FilePath = CurrentProject.Path & "\" & disposition
                
                'バイナリデータを生成する
                FileNum = FreeFile()
                Open FilePath For Binary Access Write As #FileNum
                    Put #FileNum, 1, FileData
                Close #FileNum
            Case Else
                MsgBox "ダウンロード失敗したよ"
                
                '終了処理
                Set db = Nothing
                Set rs = Nothing
                
                Exit Function
        End Select
    End With
    
    '終了処理
    Set db = Nothing
    Set rs = Nothing
    
    MsgBox "カレントディレクトリにファイルダウンロードしたよ。"
End Function

'MSHTMLを使ったURLデコード関数
Function DEcodeURLMSHTML(ByVal sWord As String) As String
    Dim d As Object
    Dim elm As MSHTML.HTMLSpanElement
    Dim objD As HTMLDocument: Set objD = New MSHTML.HTMLDocument
    sWord = Replace(sWord, "\", "\\")
    sWord = Replace(sWord, "'", "\'")
    Set d = CreateObject("htmlfile")
    Set elm = objD.createElement("span")
    elm.setAttribute "id", "result"
    objD.appendChild elm
    objD.parentWindow.execScript "document.getElementById('result').innerText = decodeURIComponent('" & sWord & "');", "JScript"
    DEcodeURLMSHTML = elm.innerText
End Function

WinHttpRequestでリクエストするURLはDriveのファイルダウンロードURL直にアクセスさせます。
Box APIを叩くでも利用したコードにて、バイナリファイルを組み立てて、カレントディレクトリに保存しています。
DecodeURLMSHTMLという関数を利用しています。利用する為には、参照設定にて「Microsoft HTML Object Library」が必要です。
ファイル名などの情報は、Content-Dispositionヘッダー内に含まれていて、ここから取り出します。ヘッダの内容は以下のような感じ

実行と結果

今回のファイルはAccessで作成していますが、主要なコマンドはリボンに組み込んであります。あらかじめ、Google Cloud Platformで控えておいた「Client ID」および「Client Secret」またGoogle DriveのファイルのIDを記述しておき、以下の手順で実行します。

Google認証を実行し、Googleへログインする
settingテーブルにAccess TokenとRefresh Tokenが格納されます。
続けて、ドライブファイルダウンロードを実行すると、このファイルと同じフォルダ内に対象のファイルがダウンロードされます。

図：これでオンライン配信がより確実に行える！！

Accessファイルのオンラインアップデート配信では、XMLファイルおよびアップデート用のインストーラやZIPファイルをGoogle Driveに格納し、外部ユーザに限定配信（組織のユーザのみ）が可能なので、VPNといった仕組みが不要です。対象のアカウントが削除されれば、Access Tokenは無効化されます。

※つまり、バージョン確認用のXMLのアクセスに１回、ファイルのダウンロードに１回の合計2回はファイルのダウンロードを実行する必要があります。

AccessでGoogle認証とファイルのダウンロード

今回使用するファイルや資料

新方式が登場しました

IE11を使わない認証対応版