2022年12月8日 / 最終更新日時 : 2024年3月21日 officeの杜 JavaScript

VBAからGoogle Driveにファイルをアップロードする

前回、GASでデータからGmailにメールをInsertするコードを作りました。この元データになるExcelのデータおよび添付ファイルのアップロード部分がまだ未作成の部分。ここはVBAで行う必要があります（eml形式にしてから取り込みは難しい）。

事前にOAuth2.0認証が必要ですが、Drive API v3を叩いてアップロードし、ファイルのIDを取得しExcelに記述するまでを行います。ファイルのIDを記述できたら、ExcelのデータをGoogleスプレッドシート側に追記するところまで実装します（とりあえずmainシートのみ）。

※index.exeを使わずに実行できる方法が出ましたので、index.exeの同梱をやめました（exeはZIPで固めてもGoogleから警告が出るので・・・）。以下のサイトを参照してみてください。

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

Google Apps ScriptでGmail APIにてメールデータを変換して追加する【GAS】

今回利用するファイル等

VBAでGoogle Driveにファイルアップロード - Excelファイル等を固めたZIP
書き込み先スプレッドシート - 前回の記事のものに追加しました。
VBA-JSON
Drive API v3
Sheets API v4

IE11は既に廃止されてるので、Puppeteerとpkgにて作成したEXEを使ってOAuth2認証を行わせます。

今回はファイルサイズ制限が5MB以下の「シンプルアップロード」を利用し、ファイルID取得→ファイル名変更・格納場所変更の２回でアップロードを実行します。

※認証後のAccess Tokenはsetting.iniファイルに直書きで記録しているので、実用する場合は暗号化するなり安全な場所に保存するなりの作業が必要になります。

図：リボンに作業コマンドを集約

新方式が登場しました

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

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

事前準備

参照設定

今回はVBA-JSONを利用している為、VBAの開発画面にて、参照設定が必要になります。以下の手順で有効化しておきましょう。

開発画面を出す
メニューよりツール→参照設定を開く
Microsoft Scripting Runtimeを探してチェックを入れてOKをクリックする

この設定はDictionaryでも利用したりするので、有効化しておくと色々捗るでしょう。

図：参照設定で有効化が必要です

認証関係の処理

今回はアップロードするに当たって、Drive API v3を利用します。Google Cloud Consoleより事前準備が必要です。また、企業内で利用する場合には、プロキシーサーバを使っているケースがあるので、そのプロキシーサーバのURLとポート番号がアクセスに必要になります。

以下のエントリーを参考に、GoogleからClient IDおよびClient Secretを取得します。その後、認証用のコードを実行して、Access Tokenを取得します。但し今回はアップロードが含まれているので、scopeは以下のようになります（https://www.googleapis.com/auth/driveが必要です。）

Private Const scope As String = "openid profile email https://www.googleapis.com/auth/spreadsheets https://www.googleapis.com/auth/drive"  '半角スペースで区切る

1	Private Const scope As String = "openid profile email https://www.googleapis.com/auth/spreadsheets https://www.googleapis.com/auth/drive" '半角スペースで区切る

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

データの構造について

前回の記事に関係してるため、今回のサンプルは以下の2つのシートによって構成されています。

メインとなるメールデータの1つずつの内容を記録したデータ（mailというテーブル名）
サブとしてそのメールに添付する複数の添付ファイルへのファイル名を記述した内容（filesというテーブル名）
mimeというシートで拡張子に応じたMIMETYPEを返すテーブル（mimeというテーブル名）

メインとサブは同じIDで連結されており、サブ側はファイルIDの欄が空のままになっているので、ここにファイルIDを追記するのが今回の目的の１つです。データ領域はテーブル化してあります。テーブルについては以下のエントリーを参考にしてみてください。

図：単純なテーブルにしてあります

Excelではテーブルとクエリを活用すると楽になる

ソースコードと解説

ファイルのアップロード

ファイルのアップロードはDrive API v3にてアップロードします。バイナリデータであるため、ちょっと扱いが難しいです。

ソースコード

'Sleepを使う
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)

'Drive Upload用エンドポイント
Public Const endpoint As String = "https://www.googleapis.com/upload/drive/v3/files?uploadType=media"
Public Const renemepoint As String = "https://www.googleapis.com/drive/v3/files/"

'アップロード先親フォルダのID
Public Const upfolder As String = "格納するフォルダのID"


'subのファイルをアップロードする（シンプルアップロード）
Public Function uploaddrive()
    'テーブルの値を配列に取得する
    Dim files
    Dim reccnt As Integer
    Dim i As Integer
    files = ThisWorkbook.Worksheets("sub").ListObjects("files").DataBodyRange
    reccnt = UBound(files, 1)
    
    'ベースになるファイルパス
    Dim basepath As String
    basepath = ThisWorkbook.Path
    
    'Access Tokenを取得する
    Dim tokenstatus As Boolean
    tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック
    
    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case True
            '無事にTokenは生きてるので何もしない
        Case False
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                Exit Function
            End If
    End Select
    
    'Access Tokenを取得する
    Dim access_token As String
    access_token = IniRead("USER", "access_token", "")
    
    'ファイル拡張子の取得用
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'JSONをパースする用の変数
    Dim doc, jsn
    'HTMLDocumentを取得
    Set doc = CreateObject("HtmlFile")
    'scriptタグを追加
    doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

    'ループでファイルへのフルパスを取得
    Dim filepath As String
    Dim Stream
    Dim mimetype As String
    Dim ext As String
    Dim temprec
    Dim requrl As String
    Dim JsonObject As Object
    
    'subシート書き込み用のカウンタ
    Dim cnt As Integer
    cnt = 2
    
    For i = 1 To reccnt
        'ファイルへのフルパスを構築
        filepath = basepath & "\" & files(i, 2)
        
        'Streamオブジェクトを用意する
        Set Stream = CreateObject("ADODB.Stream")
        Stream.Open
        Stream.Type = 1 ' adTypeBinary
        Stream.LoadFromFile = filepath
        
        'ファイルの拡張子を取得
        ext = fso.GetExtensionName(filepath)
        
        '拡張子からMIMETYPE判定
        mimetype = checkmime(ext)
        
        'リクエストを実行
        With CreateObject("WinHttp.WinHttpRequest.5.1")
            .Open "POST", endpoint, False
            '.setProxy 2, proxyuri
            .SetRequestHeader "Content-Type", mimetype
            .SetRequestHeader "Authorization", "Bearer " & access_token
            .SetRequestHeader "Content-Length", Stream.Size
            .send Stream.read(Stream.Size)
            
            '返ってきた値をもとにデータを処理
            Select Case .Status
                Case 200
                    '返ってきたJSON文字列を取得
                    Json = .ResponseText
                                  
                    'パース関数でJSONオブジェクトを取得
                    Set jsn = doc.JsonParse(Json)
                    
                    'ファイルのIDを取得する
                    temprec = CallByName(jsn, "id", VbGet)
                    
                    'リネーム用のエンドポイントを指定（ついでに移動先フォルダの指定）
                    requrl = renemepoint & temprec & "?addParents=" & upfolder
                    
                    'リクエストボディ
                    Set JsonObject = CreateObject("Scripting.Dictionary")
                    JsonObject.Add "name", files(i, 2)   'ファイル名の指定
                    
                    '3秒間ウェイトをかける
                    Sleep 3000
                                    
                    'HTTPリクエスト
                    With CreateObject("WinHttp.WinHttpRequest.5.1")
                        .Open "PATCH", requrl, False
                        '.setProxy 2, proxyuri
                        .SetRequestHeader "Content-Type", "application/json"
                        .SetRequestHeader "Authorization", "Bearer " & access_token
                        .send JsonConverter.ConvertToJson(JsonObject)
                        
                        '返ってきた値をもとにデータを処理
                        Debug.Print Status
                        Select Case .Status
                            Case 200
                                'レスポンスヘッダを取得
                                Debug.Print .getAllResponseHeaders()
                
                                '終了メッセージ
                                Debug.Print "ファイルアップロード完了"
                                
                                'ファイルIDをsubシートに書き出す
                                ThisWorkbook.Worksheets("sub").Range("C" & cnt) = temprec
                                
                                'カウンタを回す
                                cnt = cnt + 1
                
                            Case Else
                                MsgBox "ファイル名変更に失敗しました"
                        End Select
                    End With
                Case Else
                    MsgBox "アップロードに失敗しました。"
            End Select
        End With
        
        'streamオブジェクトを閉じる
        Stream.Close
        Set Stream = Nothing
        
        '3秒間ウェイトをかける
        Sleep 3000
        
    Next
    
    '終了処理
    MsgBox "アップロードが完了しました。"

End Function

'拡張子からMIMETYPEを返す
Public Function checkmime(ext) As String
    'テーブルの値を配列に取得する
    Dim files
    Dim reccnt As Integer
    Dim i As Integer
    files = ThisWorkbook.Worksheets("mime").ListObjects("mime").DataBodyRange
    reccnt = UBound(files, 1)
    
    'MIMETYPEを取得する
    Dim mime As String
    For i = 1 To reccnt
        'mimeシートの値を取得する
        mime = files(i, 1)
        
        '拡張子が一致するかどうか
        If ext = mime Then
            'MIMETYPEを返す
            checkmime = files(i, 2)
            Exit Function
        End If
    Next
    
    '見つからなかった場合
    MsgBox "対象の拡張子のMIMETYPEが見つかりませんでした"

End Functionか

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

'Sleepを使う

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

'Drive Upload用エンドポイント

Public Const endpoint As String = "https://www.googleapis.com/upload/drive/v3/files?uploadType=media"

Public Const renemepoint As String = "https://www.googleapis.com/drive/v3/files/"

'アップロード先親フォルダのID

Public Const upfolder As String = "格納するフォルダのID"

'subのファイルをアップロードする（シンプルアップロード）

Public Function uploaddrive()

'テーブルの値を配列に取得する

Dim files

Dim reccnt As Integer

Dim i As Integer

files = ThisWorkbook.Worksheets("sub").ListObjects("files").DataBodyRange

reccnt = UBound(files, 1)

'ベースになるファイルパス

Dim basepath As String

basepath = ThisWorkbook.Path

'Access Tokenを取得する

Dim tokenstatus As Boolean

tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック

'Tokenの状況に応じて処理を分岐

Select Case tokenstatus

Case True

'無事にTokenは生きてるので何もしない

Case False

'refresh token使って新しいTokenを取得

ret = getNewToken()

'取得結果を判定

If ret = True Then

'無事に取得できているのでスルーする

Else

'取得失敗

MsgBox "Access Tokenの取得に失敗しました。"

Exit Function

End If

End Select

'Access Tokenを取得する

Dim access_token As String

access_token = IniRead("USER", "access_token", "")

'ファイル拡張子の取得用

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

'JSONをパースする用の変数

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

'ループでファイルへのフルパスを取得

Dim filepath As String

Dim Stream

Dim mimetype As String

Dim ext As String

Dim temprec

Dim requrl As String

Dim JsonObject As Object

'subシート書き込み用のカウンタ

Dim cnt As Integer

cnt = 2

For i = 1 To reccnt

'ファイルへのフルパスを構築

filepath = basepath & "\" & files(i, 2)

'Streamオブジェクトを用意する

Set Stream = CreateObject("ADODB.Stream")

Stream.Open

Stream.Type = 1 ' adTypeBinary

Stream.LoadFromFile = filepath

'ファイルの拡張子を取得

ext = fso.GetExtensionName(filepath)

'拡張子からMIMETYPE判定

mimetype = checkmime(ext)

'リクエストを実行

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", endpoint, False

'.setProxy 2, proxyuri

.SetRequestHeader "Content-Type", mimetype

.SetRequestHeader "Authorization", "Bearer " & access_token

.SetRequestHeader "Content-Length", Stream.Size

.send Stream.read(Stream.Size)

'返ってきた値をもとにデータを処理

Select Case .Status

Case 200

'返ってきたJSON文字列を取得

Json = .ResponseText

'パース関数でJSONオブジェクトを取得

Set jsn = doc.JsonParse(Json)

'ファイルのIDを取得する

temprec = CallByName(jsn, "id", VbGet)

'リネーム用のエンドポイントを指定（ついでに移動先フォルダの指定）

requrl = renemepoint & temprec & "?addParents=" & upfolder

'リクエストボディ

Set JsonObject = CreateObject("Scripting.Dictionary")

JsonObject.Add "name", files(i, 2) 'ファイル名の指定

'3秒間ウェイトをかける

Sleep 3000

'HTTPリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "PATCH", requrl, False

'.setProxy 2, proxyuri

.SetRequestHeader "Content-Type", "application/json"

.SetRequestHeader "Authorization", "Bearer " & access_token

.send JsonConverter.ConvertToJson(JsonObject)

'返ってきた値をもとにデータを処理

Debug.Print Status

Select Case .Status

Case 200

'レスポンスヘッダを取得

Debug.Print .getAllResponseHeaders()

'終了メッセージ

Debug.Print "ファイルアップロード完了"

'ファイルIDをsubシートに書き出す

ThisWorkbook.Worksheets("sub").Range("C" & cnt) = temprec

'カウンタを回す

cnt = cnt + 1

Case Else

MsgBox "ファイル名変更に失敗しました"

End Select

End With

Case Else

MsgBox "アップロードに失敗しました。"

End Select

End With

'streamオブジェクトを閉じる

Stream.Close

Set Stream = Nothing

'3秒間ウェイトをかける

Sleep 3000

'終了処理

MsgBox "アップロードが完了しました。"

End Function

'拡張子からMIMETYPEを返す

Public Function checkmime(ext) As String

'テーブルの値を配列に取得する

Dim files

Dim reccnt As Integer

Dim i As Integer

files = ThisWorkbook.Worksheets("mime").ListObjects("mime").DataBodyRange

reccnt = UBound(files, 1)

'MIMETYPEを取得する

Dim mime As String

For i = 1 To reccnt

'mimeシートの値を取得する

mime = files(i, 1)

'拡張子が一致するかどうか

If ext = mime Then

'MIMETYPEを返す

checkmime = files(i, 2)

Exit Function

End If

'見つからなかった場合

MsgBox "対象の拡張子のMIMETYPEが見つかりませんでした"

End Functionか

解説

今回はファイルサイズ上限5MBのシンプルアップロードという方式でアップロードしています。また、この場合2段階に分けてリクエストをしてアップロード→リネーム＆格納場所へ移動を行う必要があります。この他にmultipartとresumableの2つの方式があり、5MB以上のものをアップロードする場合には、resumableの方式で構築が必要です（この場合、1度のアップロードでファイル名や格納先を指定できる）

upfolderに格納先のフォルダのIDを入れる必要があります。
アップロード時にリクエストのcontent-typeに対象ファイルのMIMETYPEが必要なので、mimeに使うファイルのMIMETYPEを事前に格納しておく必要があります。
MIMETYPEはファイルの拡張子から判定するcheckmime関数で返すようにしています。
subのテーブルデータを取得し、Access Tokenを取得してループでリクエストを回します。
1回目のリクエストでアップロードします。POSTで送信し、Streamを利用してファイルを取得し、Content-Lengthでファイルサイズの指定が必要です。
アップロードが成功するとレスポンスの中にファイルIDが入ってるので、CallByName関数で取り出します。
2回目の取得はDictionaryでリクエストBodyを作成し、違うエンドポイントでPATCHにてリクエストを送ります。
このときのエンドポイントにaddParentsとフォルダのIDを指定することで、指定のフォルダにファイルが移動します。
移動とリネームが完了したら、ExcelファイルへファイルのIDを書き込みします。
連続してリクエストすると429エラーになることがあるので、3秒間のSleepをリクエスト間に入れてあります。

シートデータの送信

シートデータの送信は、Sheets API v4を使って送信します。送信するデータはJSONにする必要がある点と、2次元配列を作る必要があるため、そこがネックになります。GASでSheets APIを使う手法は以下のエントリーを御覧ください。

Google Apps ScriptでSheets APIを使ったら爆速だった【GAS】

追記する形でデータを送信する

ソースコード

'書き込み先スプレッドシートID
Public Const sheetid As String = "書き込み先SpreadsheetのIDを記入"

'Sheets API V4エンドポイント
Public Const appendpoint As String = "https://sheets.googleapis.com/v4/spreadsheets/"


'シートデータを送り込む関数
Public Function sheetdatasend()
    'JSONデータを構築する変数
    Dim bufman As New Dictionary
    Dim bufColl As New Collection
    Dim dataColl As New Collection

    'mainテーブルの内容を取得する
    Dim files
    Dim reccnt As Integer
    Dim addr As String
    
    '書き込みRangeを指定する（シート名!書込み開始位置）
    Dim rangeman As String
    rangeman = "main!A2"
    
    '書き込み用エンドポイントを構築
    Dim apurl As String
    apurl = appendpoint & sheetid & "/values/" & rangeman & ":append?valueInputOption=USER_ENTERED"
    
    'Access Tokenを取得する
    Dim tokenstatus As Boolean
    tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック
    
    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case True
            '無事にTokenは生きてるので何もしない
        Case False
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                Exit Function
            End If
    End Select
    
    'Access Tokenを取得する
    Dim access_token As String
    access_token = IniRead("USER", "access_token", "")

    With ThisWorkbook.Worksheets("main").ListObjects("mail")
        'データを取得
        files = .DataBodyRange
        
        'データの個数を調べる
        reccnt = UBound(files, 1)
        
        If reccnt = 0 Then
            'データ無しなので処理をスルーする
            MsgBox "送るべきデータがありませんでした。"
            Exit Function
        Else
             'テーブルから配列を作成する
            For i = 1 To reccnt
                'ワークシートのデータを1行分取得する
                For j = 1 To 6
                    Call dataColl.Add(files(i, j))
                Next j
                        
                'dataCollをbufCollに追加
                Call bufColl.Add(dataColl)
                
                'dataCollを初期化
                Set dataColl = Nothing
                Set dataColl = New Collection
            
            Next i
        End If
    End With
    
    'CollectionをDictionaryに格納
    Call bufman.Add("values", bufColl)

    'HTTPリクエスト
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "POST", apurl, False
        '.setProxy 2, proxyuri
        .SetRequestHeader "Authorization", "Bearer " & access_token
        .SetRequestHeader "Content-Type", "application/json"
        .send JsonConverter.ConvertToJson(bufman)
                        
        '返ってきた値をもとにデータを処理
        Select Case .Status
            Case 200
                MsgBox "シートデータの送信に成功しました。"
            Case Else
                MsgBox "シートデータの送信に失敗しました。"
        End Select
    End With

End Function

100

101

102

103

104

'書き込み先スプレッドシートID

Public Const sheetid As String = "書き込み先SpreadsheetのIDを記入"

'Sheets API V4エンドポイント

Public Const appendpoint As String = "https://sheets.googleapis.com/v4/spreadsheets/"

'シートデータを送り込む関数

Public Function sheetdatasend()

'JSONデータを構築する変数

Dim bufman As New Dictionary

Dim bufColl As New Collection

Dim dataColl As New Collection

'mainテーブルの内容を取得する

Dim files

Dim reccnt As Integer

Dim addr As String

'書き込みRangeを指定する（シート名!書込み開始位置）

Dim rangeman As String

rangeman = "main!A2"

'書き込み用エンドポイントを構築

Dim apurl As String

apurl = appendpoint & sheetid & "/values/" & rangeman & ":append?valueInputOption=USER_ENTERED"

'Access Tokenを取得する

Dim tokenstatus As Boolean

tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック

'Tokenの状況に応じて処理を分岐

Select Case tokenstatus

Case True

'無事にTokenは生きてるので何もしない

Case False

'refresh token使って新しいTokenを取得

ret = getNewToken()

'取得結果を判定

If ret = True Then

'無事に取得できているのでスルーする

Else

'取得失敗

MsgBox "Access Tokenの取得に失敗しました。"

Exit Function

End If

End Select

'Access Tokenを取得する

Dim access_token As String

access_token = IniRead("USER", "access_token", "")

With ThisWorkbook.Worksheets("main").ListObjects("mail")

'データを取得

files = .DataBodyRange

'データの個数を調べる

reccnt = UBound(files, 1)

If reccnt = 0 Then

'データ無しなので処理をスルーする

MsgBox "送るべきデータがありませんでした。"

Exit Function

Else

'テーブルから配列を作成する

For i = 1 To reccnt

'ワークシートのデータを1行分取得する

For j = 1 To 6

Call dataColl.Add(files(i, j))

Next j

'dataCollをbufCollに追加

Call bufColl.Add(dataColl)

'dataCollを初期化

Set dataColl = Nothing

Set dataColl = New Collection

Next i

End If

End With

'CollectionをDictionaryに格納

Call bufman.Add("values", bufColl)

'HTTPリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", apurl, False

'.setProxy 2, proxyuri

.SetRequestHeader "Authorization", "Bearer " & access_token

.SetRequestHeader "Content-Type", "application/json"

.send JsonConverter.ConvertToJson(bufman)

'返ってきた値をもとにデータを処理

Select Case .Status

Case 200

MsgBox "シートデータの送信に成功しました。"

Case Else

MsgBox "シートデータの送信に失敗しました。"

End Select

End With

End Function

解説

今回はExcelのmainシートの内容を、Google Spreadsheet側のmainシートに「追記型」で記入するようにしています。追記なのでデータが存在する場合、一番下の場所から自動的に判定して入れてくれます。書き込み先スプレッドシートは冒頭に掲示してるものを使っています。

rangeman変数には、シート名!書き込み開始セル番地を指定します。これでシート名と配列データの書き込みする左上のポイントが指定出来ます。特にバッチリサイズを合わせる必要は有りません。
リクエストエンドポイントに「?valueInputOption=USER_ENTERED」を追加することで、値の型を判定して挿入してくれます。ROWを指定した場合は、変換せずそのまま追記します。
テーブルデータを取得して、1行文のdataCollコレクションにデータを追加。これが1次元目の配列になります。
都度、bufCollにdataCollを追加。これが2次元目になります。
最後にbufmanに対してvaluesとしてDictionaryを構築して、bufCollを追加することでリクエストするJSONオブジェクトを構築出来ます。
POSTでリクエストをし、JsonConverter.ConvertToJsonでbufmanをJSON化して送信。200が返ってくれば無事に書き込みが完了です。

図：無事にデータの送信が出来ました。

構築したJSONのサンプル

{
  "values": [
    ["value1", "value2"]
  ]
}

{

"values": [

["value1", "value2"]

]

}

Debug.Print JsonConverter.ConvertToJson(bufman)でデバッグ出来ます。スプレッドシートのデータをvaluesの配列の中に、1行ずつ配列を加えて、二次元配列の形にしています。

複数のシートデータをまとめて送信する

ソースコード

'シートデータをbatchupdateで送る方法
Public Function batchSendData()
    'JSONデータを構築する変数
    Dim bufman As New Dictionary
    Dim masterman As New Dictionary
    Dim bufColl As New Collection
    Dim dataColl As New Collection
    Dim sheetman As New Collection

    'mainテーブルの内容を取得する
    Dim files
    Dim reccnt As Integer
    Dim addr As String
    
    'バッチ書き込み用エンドポイントを構築
    Dim apurl As String
    apurl = appendpoint & sheetid & "/values:batchUpdate?valueInputOption=USER_ENTERED"

    'Access Tokenを取得する
    Dim tokenstatus As Boolean
    tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック
    
    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case True
            '無事にTokenは生きてるので何もしない
        Case False
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                Exit Function
            End If
    End Select
    
    'Access Tokenを取得する
    Dim access_token As String
    access_token = IniRead("USER", "access_token", "")
    
    'mainシートデータを生成
    With ThisWorkbook.Worksheets("main").ListObjects("mail")
        'Databodyrangeのアドレス範囲を取得
        addr = .DataBodyRange.SpecialCells(xlCellTypeVisible).Address
    
        'データを取得
        files = .DataBodyRange
        
        'データの個数を調べる
        reccnt = UBound(files, 1)
        
        If reccnt = 0 Then
            'データ無しなので処理をスルーする
            MsgBox "送るべきデータがありませんでした。"
            Exit Function
        Else
             'テーブルから配列を作成する
            For i = 1 To reccnt
                'ワークシートのデータを1行分取得する
                For j = 1 To 6
                    Call dataColl.Add(files(i, j))
                Next j
                        
                'dataCollをbufCollに追加
                Call bufColl.Add(dataColl)
                
                'dataCollを初期化
                Set dataColl = Nothing
                Set dataColl = New Collection
            
            Next i
        End If
    End With
    
    'DictionaryにRangeを格納
    Call bufman.Add("range", "main!" & addr)
    
    'CollectionをDictionaryに格納
    Call bufman.Add("values", bufColl)
    
    'data Collectionにbufmanを追加
    Call sheetman.Add(bufman)
    
    'bufman,bufcollを初期化
    Set bufColl = Nothing
    Set bufColl = New Collection
    Set bufman = Nothing
    Set bufman = New Dictionary
    
    'subシートデータを生成
    With ThisWorkbook.Worksheets("sub").ListObjects("files")
        'Databodyrangeのアドレス範囲を取得
        addr = .DataBodyRange.SpecialCells(xlCellTypeVisible).Address
    
        'データを取得
        files = .DataBodyRange
        
        'データの個数を調べる
        reccnt = UBound(files, 1)
        
        Debug.Print files(1, 3)
        
        
        If reccnt = 0 Then
            'データ無しなので処理をスルーする
            MsgBox "送るべきデータがありませんでした。"
            Exit Function
        Else
             'テーブルから配列を作成する
            For i = 1 To reccnt
                'ワークシートのデータを1行分取得する
                For j = 1 To 3
                    Call dataColl.Add(files(i, j))
                Next j
                        
                'dataCollをbufCollに追加
                Call bufColl.Add(dataColl)
                
                'dataCollを初期化
                Set dataColl = Nothing
                Set dataColl = New Collection
            
            Next i
        End If
    End With
    
    'DictionaryにRangeを格納
    Call bufman.Add("range", "sub!" & addr)
    
    'CollectionをDictionaryに格納
    Call bufman.Add("values", bufColl)
    
    'data Collectionにbufmanを追加
    Call sheetman.Add(bufman)
    
    'mastermanに追加
    Call masterman.Add("data", sheetman)
    
    'HTTPリクエスト
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "POST", apurl, False
        '.setProxy 2, proxyuri
        .SetRequestHeader "Authorization", "Bearer " & access_token
        .SetRequestHeader "Content-Type", "application/json"
        .send JsonConverter.ConvertToJson(masterman)
                        
        '返ってきた値をもとにデータを処理
        Debug.Print .Status
        Select Case .Status
            Case 200
                MsgBox "シートデータの送信に成功しました。"
            Case Else
                MsgBox "シートデータの送信に失敗しました。"
        End Select
    End With

End Function

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

'シートデータをbatchupdateで送る方法

Public Function batchSendData()

'JSONデータを構築する変数

Dim bufman As New Dictionary

Dim masterman As New Dictionary

Dim bufColl As New Collection

Dim dataColl As New Collection

Dim sheetman As New Collection

'mainテーブルの内容を取得する

Dim files

Dim reccnt As Integer

Dim addr As String

'バッチ書き込み用エンドポイントを構築

Dim apurl As String

apurl = appendpoint & sheetid & "/values:batchUpdate?valueInputOption=USER_ENTERED"

'Access Tokenを取得する

Dim tokenstatus As Boolean

tokenstatus = checkExpireToken() 'Access Tokenの取得と失効チェック

'Tokenの状況に応じて処理を分岐

Select Case tokenstatus

Case True

'無事にTokenは生きてるので何もしない

Case False

'refresh token使って新しいTokenを取得

ret = getNewToken()

'取得結果を判定

If ret = True Then

'無事に取得できているのでスルーする

Else

'取得失敗

MsgBox "Access Tokenの取得に失敗しました。"

Exit Function

End If

End Select

'Access Tokenを取得する

Dim access_token As String

access_token = IniRead("USER", "access_token", "")

'mainシートデータを生成

With ThisWorkbook.Worksheets("main").ListObjects("mail")

'Databodyrangeのアドレス範囲を取得

addr = .DataBodyRange.SpecialCells(xlCellTypeVisible).Address

'データを取得

files = .DataBodyRange

'データの個数を調べる

reccnt = UBound(files, 1)

If reccnt = 0 Then

'データ無しなので処理をスルーする

MsgBox "送るべきデータがありませんでした。"

Exit Function

Else

'テーブルから配列を作成する

For i = 1 To reccnt

'ワークシートのデータを1行分取得する

For j = 1 To 6

Call dataColl.Add(files(i, j))

Next j

'dataCollをbufCollに追加

Call bufColl.Add(dataColl)

'dataCollを初期化

Set dataColl = Nothing

Set dataColl = New Collection

Next i

End If

End With

'DictionaryにRangeを格納

Call bufman.Add("range", "main!" & addr)

'CollectionをDictionaryに格納

Call bufman.Add("values", bufColl)

'data Collectionにbufmanを追加

Call sheetman.Add(bufman)

'bufman,bufcollを初期化

Set bufColl = Nothing

Set bufColl = New Collection

Set bufman = Nothing

Set bufman = New Dictionary

'subシートデータを生成

With ThisWorkbook.Worksheets("sub").ListObjects("files")

'Databodyrangeのアドレス範囲を取得

addr = .DataBodyRange.SpecialCells(xlCellTypeVisible).Address

'データを取得

files = .DataBodyRange

'データの個数を調べる

reccnt = UBound(files, 1)

Debug.Print files(1, 3)

If reccnt = 0 Then

'データ無しなので処理をスルーする

MsgBox "送るべきデータがありませんでした。"

Exit Function

Else

'テーブルから配列を作成する

For i = 1 To reccnt

'ワークシートのデータを1行分取得する

For j = 1 To 3

Call dataColl.Add(files(i, j))

Next j

'dataCollをbufCollに追加

Call bufColl.Add(dataColl)

'dataCollを初期化

Set dataColl = Nothing

Set dataColl = New Collection

Next i

End If

End With

'DictionaryにRangeを格納

Call bufman.Add("range", "sub!" & addr)

'CollectionをDictionaryに格納

Call bufman.Add("values", bufColl)

'data Collectionにbufmanを追加

Call sheetman.Add(bufman)

'mastermanに追加

Call masterman.Add("data", sheetman)

'HTTPリクエスト

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "POST", apurl, False

'.setProxy 2, proxyuri

.SetRequestHeader "Authorization", "Bearer " & access_token

.SetRequestHeader "Content-Type", "application/json"

.send JsonConverter.ConvertToJson(masterman)

'返ってきた値をもとにデータを処理

Debug.Print .Status

Select Case .Status

Case 200

MsgBox "シートデータの送信に成功しました。"

Case Else

MsgBox "シートデータの送信に失敗しました。"

End Select

End With

End Function

解説

今回はExcelのmainおよびsubの2つのシートをまとめて送信して、「上書き型」で記入するようにしています。上書きであるため、書き込む範囲をしっかり指定する必要があるのと、データは上書きされてしまうので要注意です。

前述に加えて、最後にsheetmanというcollectionにbufmanを加える形にしてあります。
前回と異なり、valuesだけでなくrangeでmain!A2:F3といった形での指定が必要です。そのためにテーブルからDataBodyRange.SpecialCells(xlCellTypeVisible).Addressで範囲を取得しています。
次のsubシートを処理する前に、bufmanとbufcollを初期化してからでないとデータが混ざってしまうので初期化します。
subシートも処理が終わったら最後に、mastermanというDictionaryの「data」にsheetmanを加えてデータの構築は完了
リクエストエンドポイントは前回と異なり、「https://sheets.googleapis.com/v4/spreadsheets/シートID/values:batchUpdate」となります。
リクエストの処理そのものは、前述のものと同じです。

構築したJSONのサンプル

前述とは違い、dataの中に複数のvaluesの中身とRange指定を追加する必要があります。故にそこをCollectionとDictionaryの2つでうまいこと構築するのがVBAでのポイントになります。

{
    "data":[
        {
            "range":"main!A2:F3",
            "values":[
                [1,"\u6211\u5B6B\u5B50","\u6C17\u4ED9\u6CBC","aaaa","\u3042\u3042\u3042\u3042",9999],
                [2,"\u5317\u4E5D\u5DDE","\u6A2A\u9808\u8CC0","bbbb","\u3076\u3076\u3076\u3076",9999]
            ]
        },
        {
            "range":"sub!A2:C3",
            "values":[
                [1,"\u6211\u5B6B\u5B50","\u6C17\u4ED9\u6CBC","aaaa"],
                [2,"\u5317\u4E5D\u5DDE","\u6A2A\u9808\u8CC0","bbbb"]
            ]
        }
    ]
}

{

"data":[

{

"range":"main!A2:F3",

"values":[

[1,"\u6211\u5B6B\u5B50","\u6C17\u4ED9\u6CBC","aaaa","\u3042\u3042\u3042\u3042",9999],

[2,"\u5317\u4E5D\u5DDE","\u6A2A\u9808\u8CC0","bbbb","\u3076\u3076\u3076\u3076",9999]

]

{

"range":"sub!A2:C3",

"values":[

[1,"\u6211\u5B6B\u5B50","\u6C17\u4ED9\u6CBC","aaaa"],

[2,"\u5317\u4E5D\u5DDE","\u6A2A\u9808\u8CC0","bbbb"]

]

}

]

}

VBAからGoogle Driveにファイルをアップロードする

今回利用するファイル等

新方式が登場しました

事前準備

参照設定

認証関係の処理

データの構造について

ソースコードと解説

ファイルのアップロード

ソースコード

解説

シートデータの送信

追記する形でデータを送信する

ソースコード

解説

構築したJSONのサンプル

複数のシートデータをまとめて送信する

ソースコード

解説

構築したJSONのサンプル

関連リンク

コメントを残すコメントをキャンセル

Google Apps ScriptでGmail APIにてメールデータを変換して追加する【GAS】

Raspberry Pi 4で教育用環境を構築する

今回利用するファイル等

新方式が登場しました

事前準備

参照設定

認証関係の処理

データの構造について

ソースコードと解説

ファイルのアップロード

ソースコード

解説

シートデータの送信

追記する形でデータを送信する

ソースコード

解説

構築したJSONのサンプル

複数のシートデータをまとめて送信する

ソースコード

解説

構築したJSONのサンプル

関連リンク

コメントを残す コメントをキャンセル

Google Apps ScriptでGmail APIにてメールデータを変換して追加する【GAS】

Raspberry Pi 4で教育用環境を構築する

コメントを残すコメントをキャンセル