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を使わない認証対応版