現在、VBAで業務用アプリケーションを作成していますが、アップデータの配布に於いてイントラネット内に配置ですと、外部ではアップデートが出来ないことになります。かといって、VPNの設定などをして入れるようにするというのも考えもの。ということで、アップデータの配布にG SuiteのGoogle Driveを使えないか？
ということで、VBAにてGoogle認証をし、Drive APIを叩いてファイルをダウンロードする手段を考えました。Client IDや
Client Secretがあっても今回の手法の場合、組織内のアカウントでない場合、認証が通らずダウンロードが出来ません。また、この手法の場合、ファイルへのアクセス権が全くなくとも、ファイルオーナーの自分だけはダウンロードが可能になったりします。とても便利。今回はAccess VBAにて作成しています。
難易度：
リンク
目次
今回使用するファイルや資料
事前準備
プロジェクトの作成
今回は、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認証の為のコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 |
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テーブルに格納しています。
ファイルのダウンロードの為のコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
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」が必要です。
実行と結果
今回のファイルは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回はファイルのダウンロードを実行する必要があります。
関連リンク
- download file from google drive
- VBAマクロからGoogle Apps Script Execution APIを呼び出す。
- EXCEL2013以降64BIT版で簡単URLエンコード EXCEL2013 Later URLEncode Function
- 64ビット版OfficeでURLエンコード処理ができない？
- paulsteigel/Google-Drive-VBA-integration
- 投稿タグ
- access, Drive API, Google Drive, OAuth, vba
