2021年10月15日 / 最終更新日時 : 2021年11月19日 officeの杜 msoffice

Box上のExcelファイルを競合させずに読み書きする

クラウドストレージのBox、とりわけBox Driveを利用していると頻繁に遭遇するのが「ファイルの競合」。つまり、複数名でファイルに上書きを行うとデータの整合性がなくなり、片方のファイルはオリジナルから分離されて、コピーとして別ファイル化され、後でトラブルになるというパターンです。

ファイルサーバでは無いので、複数名で同時に開いて同時に編集といったことは、Microsoft365のExcel Online Business（有償）があればウェブ上で可能と言えば可能ですが、無い・許可されていない、またブック間リンクやらAccessのリンクテーブルで利用などが理由で、Box Driveを使ってる場合だと避けがたい問題です。

という事で今回、Box APIを利用してこれを回避しつつ複数名で書き込みができないか挑戦してみました。時間が出来たら、更新時の処理や削除時の対策なども追加しようと思います。

1 今回使用するファイル等
2 Box Driveの場合の問題点
3 事前準備
4 ソースコードと解説
5 仕組み
6 関連リンク

今回使用するファイル等

Boxmerge - 書き込み用のAccessプログラム
database.xlsx - 書き込み先のBoxに配置するExcelファイル
Box API
VBA-JSON

今回の記事は過去に公開済みの以下のエントリーをベースに進めていますので、Box API使用の事前準備や認証の仕組みなどについては、以下のエントリーを参考に進めてください。

VBAからBox APIを叩いてみる – 準備編

Box Driveの場合の問題点

共有フォルダというフォルダを2名の間で共有し、Box Driveを使えばアップロードとダウンロードのコードを省けるか？と考えてテストしてみましたが、非常に問題点が多い。理由はネットワークにあるのではなく、Box Drive自体の同期するスピードがあまりにも緩慢で、Box Drive上のファイルに対してリンクテーブルを貼って更新を掛けても、対象のxlsxファイル自体が同期がなされていない為、古いファイルのまま。

これでは、読み書きに大きなタイムラグが生じるため、仕方なくBox Driveでファイルの読み書きを今回のプログラムでは実装せずに、都度ダウンロードとアップロードを行う仕様にしています。

酷い時には30秒くらいタイムラグがあったので、ファイルの上書きバッティングが起こりかねません。Boxはあまり事務方向きではないですね。

事前準備

ここでの事前準備は、予め取得しておいたClient IDや配置するdatabase.xlsxのBox上のID、格納するフォルダのIDなどの利用するにあたっての事前作業になります。

database.xlsxの配置

書き込みをする為のExcelファイルで、データの登録部分は今回はテーブル化してあります。Box上にある適当なフォルダを用意して、その中にアップロードしておきます。

この時

配置するフォルダのIDを取得しておきます
アップロード後のdatabase.xlsxのファイルのIDを取得しておきます。

この後、プログラム内でこの２つのIDを記述することになります。

boxmerge.accdbの編集

本来は設定用の窓と、設定値を保存する為の仕組みを用意しておくべきなのですが、今回はそれらは取っ払って、コード内に取得済みの設定値を書き込んでおきます。書き込み先はboxauthの標準モジュールになります。最上部のgeneral部に記述します。

client_idにBox APIのクライアントIDの値を書き込む
client_secretにBox APIのクライアントシークレットの値を書き込む
redirecturlにBox APIに設定したリダイレクトURLの値を書き込む
fileidには、前項で取得したファイルのIDを書き込む
folderidには、前項で取得したアップロード先のフォルダのIDを書き込む

図：これらを使って認証を行います。

認証の実行

前項で各種値を書き込んで、boxAuthorizationを実行するとIEが起動しBoxのログイン画面が出ます。そこでログインに認証を実行すると、Access Tokenが取得されて、tokeninfoテーブルにそれぞれデータが追記される仕組みになっています。

デバッグしてみると、最後リダイレクト先に遷移した際のURLの後半に認証コードが含まれています。リダイレクト先がlocalhostの場合、ここが失敗してcodeが入っていないことがあります。

ここまで完了したら、Box APIを使ってのExcelファイルの読み書きをAccess上のプログラムから行えるようになっています。

例：https://officeforest.org/wp/?state=authenticated&code=ここに認証コードが入ってる

図：Boxへのログイン画面が出てきます。

図：認証を要求してくるので許可しましょう。

ソースコードと解説

ファイルのロック状態を取得する

'ロック状態をチェックする
Public Function boxlockchek() As String
    '変数の宣言
    Dim ret As Variant

    'DB接続用
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

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

    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case 0
            '無事にTokenは生きてるので何もしない
        Case 1
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            Exit Function
    End Select

    'URLの組み立て
    Dim strUri As String
    Dim strMethod As String
    strUri = filepoint & fileid & lockman
    strMethod = "GET"

    'Access Tokenを取得する
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token

    'リクエストの送信
    Dim lockmode As Variant
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open strMethod, strUri, False
        '.setProxy 2, proxyuri
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send
        
        '返ってきた値をもとにデータを処理
        Select Case .status
            Case 200, 201
                'JSONデータを取得する
                Json = .responseText
                
                'JSON取得用
                Dim doc, jsn
                Dim tempjson, temprec, tempval
                
                'HTMLDocumentを取得
                Set doc = CreateObject("HtmlFile")
                'scriptタグを追加
                doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"

                'パース関数でJSONオブジェクトを取得
                Set jsn = doc.JsonParse(Json)

                'ロック状態を取得する
                lockmode = jsn.lock
                
                'ロック状態を返す
                If IsNull(lockmode) Then
                    boxlockchek = "OK"
                Else
                    boxlockchek = "NG"
                End If

            Case Else
                MsgBox .status & "エラー"
        End Select
    End With

    '終了処理
    Set rs = Nothing
    Set db = Nothing
    
End Function

'ロック状態をチェックする

Public Function boxlockchek() As String

'変数の宣言

Dim ret As Variant

'DB接続用

Dim db As DAO.Database

Dim rs As DAO.Recordset

'Access Tokenの取得と失効チェック

Dim tokenstatus As Integer

tokenstatus = checkExpireToken()

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

Select Case tokenstatus

Case 0

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

Case 1

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

ret = getNewToken()

'取得結果を判定

If ret = True Then

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

Else

'取得失敗

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

Exit Function

End If

Case 2

'60日オーバーなので再認証をする

Call boxAuthorization

'終了処理

MsgBox "認証が期限切れです。再認証を実行してください。"

Exit Function

End Select

'URLの組み立て

Dim strUri As String

Dim strMethod As String

strUri = filepoint & fileid & lockman

strMethod = "GET"

'Access Tokenを取得する

Set db = CurrentDb()

Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)

Dim access_token As String

access_token = rs!access_token

'リクエストの送信

Dim lockmode As Variant

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open strMethod, strUri, False

'.setProxy 2, proxyuri

.setRequestHeader "Authorization", "Bearer " & access_token

.send

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

Select Case .status

Case 200, 201

'JSONデータを取得する

Json = .responseText

'JSON取得用

Dim doc, jsn

Dim tempjson, temprec, tempval

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

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

Set jsn = doc.JsonParse(Json)

'ロック状態を取得する

lockmode = jsn.lock

'ロック状態を返す

If IsNull(lockmode) Then

boxlockchek = "OK"

Else

boxlockchek = "NG"

End If

Case Else

MsgBox .status & "エラー"

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

End Function

標準のGETリクエストではlockの状態が帰ってこないので、https://api.box.com/2.0/files/fileid/?fields=lockにて、追加のフィールドを取得するエントリポイントでもってリクエストが必要です。
ロックされていない場合は、lockの値がNullで返ってくるので、これを元に判定し、ロックされてる場合は処理を中止します

ファイルに対してロックする

'Boxのファイルをロックするルーチン
Public Function BoxFileLock() As Boolean
    '変数の宣言
    Dim ret As Variant

    'DB接続用
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

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

    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case 0
            '無事にTokenは生きてるので何もしない
        Case 1
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                BoxFileLock = False
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            BoxFileLock = False
            Exit Function
    End Select

    'Boxへ送信するファイルとその情報
    Dim strMethod As String: strMethod = "PUT"
    Dim strUri As String
    Dim strResult As String

    'URLの組み立て
    strUri = filepoint & fileid

    'Access Tokenを取得する]
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token

    'リクエストパラメータの構築
    Dim JsonObject As Object
    Set JsonObject = New Dictionary
    JsonObject.Add "lock", New Dictionary
    JsonObject("lock").Add "type", "lock"
    JsonObject("lock").Add "is_download_prevented", False

    'リクエストの送信
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open strMethod, strUri, False
        '.setProxy 2, proxyuri
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send JsonConverter.ConvertToJson(JsonObject)

        '返ってきた値をもとにデータを処理
        Select Case .status
            Case 200, 201
                'レスポンスヘッダを取得
                Debug.Print .GetAllResponseHeaders()
                
                '投稿結果
                strResult = .responseText
                
                Debug.Print strResult

            Case Else
                MsgBox .status & "エラー。ファイルのロックは失敗しました。"
                BoxFileLock = False
                '終了処理
                Set rs = Nothing
                Set db = Nothing
                Exit Function
        End Select
    End With

    '終了処理
    Set rs = Nothing
    Set db = Nothing
    
    '値を返す
    BoxFileLock = True

End Function

'Boxのファイルをロックするルーチン

Public Function BoxFileLock() As Boolean

'変数の宣言

Dim ret As Variant

'DB接続用

Dim db As DAO.Database

Dim rs As DAO.Recordset

'Access Tokenの取得と失効チェック

Dim tokenstatus As Integer

tokenstatus = checkExpireToken()

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

Select Case tokenstatus

Case 0

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

Case 1

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

ret = getNewToken()

'取得結果を判定

If ret = True Then

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

Else

'取得失敗

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

BoxFileLock = False

Exit Function

End If

Case 2

'60日オーバーなので再認証をする

Call boxAuthorization

'終了処理

MsgBox "認証が期限切れです。再認証を実行してください。"

BoxFileLock = False

Exit Function

End Select

'Boxへ送信するファイルとその情報

Dim strMethod As String: strMethod = "PUT"

Dim strUri As String

Dim strResult As String

'URLの組み立て

strUri = filepoint & fileid

'Access Tokenを取得する]

Set db = CurrentDb()

Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)

Dim access_token As String

access_token = rs!access_token

'リクエストパラメータの構築

Dim JsonObject As Object

Set JsonObject = New Dictionary

JsonObject.Add "lock", New Dictionary

JsonObject("lock").Add "type", "lock"

JsonObject("lock").Add "is_download_prevented", False

'リクエストの送信

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open strMethod, strUri, False

'.setProxy 2, proxyuri

.setRequestHeader "Authorization", "Bearer " & access_token

.send JsonConverter.ConvertToJson(JsonObject)

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

Select Case .status

Case 200, 201

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

Debug.Print .GetAllResponseHeaders()

'投稿結果

strResult = .responseText

Debug.Print strResult

Case Else

MsgBox .status & "エラー。ファイルのロックは失敗しました。"

BoxFileLock = False

'終了処理

Set rs = Nothing

Set db = Nothing

Exit Function

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

'値を返す

BoxFileLock = True

End Function

以前の記事にも記述した、ロックを掛けるコード。但し今回は無期限でロックを掛けるので、expires_atの指定はしていません。
is_download_preventedにて、ダウンロードも不可の設定も行っています。
ロックさせる事で、他者に対してファイルの上書きを阻止し、自分自身がキープする事が可能になります。

ファイルのロックを解除する

Excelファイルに1行データを書き込んだら、速やかにロックを掛けてアップロードを行い、最後にロックを解除して上げる必要があります。

'Boxのファイルをロックを解除するルーチン
Public Function BoxFileUnLock() As Boolean
    '変数の宣言
    Dim ret As Variant

    'DB接続用
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

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

    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case 0
            '無事にTokenは生きてるので何もしない
        Case 1
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                BoxFileUnLock = False
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            BoxFileUnLock = False
            Exit Function
    End Select

    'Boxへ送信するファイルとその情報
    Dim strMethod As String: strMethod = "PUT"
    Dim strUri As String
    Dim strResult As String

    'URLの組み立て
    strUri = filepoint & fileid

    'Access Tokenを取得する]
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token

    'リクエストパラメータの構築
    Dim JsonObject As Object
    Set JsonObject = New Dictionary
    JsonObject.Add "lock", Null

    'リクエストの送信
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open strMethod, strUri, False
        '.setProxy 2, proxyuri
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send JsonConverter.ConvertToJson(JsonObject)

        '返ってきた値をもとにデータを処理
        Debug.Print .status
        Select Case .status
            Case 200, 201
                
                '投稿結果
                strResult = .responseText

            Case Else
                MsgBox .status & "エラー。ファイルのロック解除は失敗しました。"
                BoxFileUnLock = False
                '終了処理
                Set rs = Nothing
                Set db = Nothing
                Exit Function
        End Select
    End With

    '終了処理
    Set rs = Nothing
    Set db = Nothing
    
    '値を返す
    BoxFileUnLock = True

End Function

'Boxのファイルをロックを解除するルーチン

Public Function BoxFileUnLock() As Boolean

'変数の宣言

Dim ret As Variant

'DB接続用

Dim db As DAO.Database

Dim rs As DAO.Recordset

'Access Tokenの取得と失効チェック

Dim tokenstatus As Integer

tokenstatus = checkExpireToken()

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

Select Case tokenstatus

Case 0

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

Case 1

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

ret = getNewToken()

'取得結果を判定

If ret = True Then

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

Else

'取得失敗

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

BoxFileUnLock = False

Exit Function

End If

Case 2

'60日オーバーなので再認証をする

Call boxAuthorization

'終了処理

MsgBox "認証が期限切れです。再認証を実行してください。"

BoxFileUnLock = False

Exit Function

End Select

'Boxへ送信するファイルとその情報

Dim strMethod As String: strMethod = "PUT"

Dim strUri As String

Dim strResult As String

'URLの組み立て

strUri = filepoint & fileid

'Access Tokenを取得する]

Set db = CurrentDb()

Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)

Dim access_token As String

access_token = rs!access_token

'リクエストパラメータの構築

Dim JsonObject As Object

Set JsonObject = New Dictionary

JsonObject.Add "lock", Null

'リクエストの送信

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open strMethod, strUri, False

'.setProxy 2, proxyuri

.setRequestHeader "Authorization", "Bearer " & access_token

.send JsonConverter.ConvertToJson(JsonObject)

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

Debug.Print .status

Select Case .status

Case 200, 201

'投稿結果

strResult = .responseText

Case Else

MsgBox .status & "エラー。ファイルのロック解除は失敗しました。"

BoxFileUnLock = False

'終了処理

Set rs = Nothing

Set db = Nothing

Exit Function

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

'値を返す

BoxFileUnLock = True

End Function

ロックを掛ける場合と殆どコードは同じ
異なる点は、JsonObject.Add "lock", Nullとする所。Nullとしてリクエストするとロックが解除されます。

ファイルのアップロード

Public Function BoxUploadFile()
    '変数の宣言
    Dim ret As Variant

    'DB接続用
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

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

    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case 0
            '無事にTokenは生きてるので何もしない
        Case 1
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            Exit Function
    End Select

    'Boxへ送信するファイルとその情報
    Dim filepath As String: filepath = CurrentProject.Path & "\" & "database.xlsx"
    Dim strMethod As String: strMethod = "POST"
    Dim strUri As String
    Dim strResult As String

    'URLの組み立て
    strUri = uploadpoint & fileid & "/content"

    'ファイルのMIME TYPE
    Dim contentType As String
    contentType = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"

    'Access Tokenを取得する
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token

    'ADODBで領域確保
    Dim tempParamStream As Object
    Set tempParamStream = CreateObject("ADODB.Stream")
    tempParamStream.Open

    'リクエストパラメータを構築
    Dim FileName As String
    FileName = Dir(filepath)

    Dim JsonObject As Object
    Set JsonObject = New Dictionary

    JsonObject.Add "name", FileName
    JsonObject.Add "parent", New Dictionary
    JsonObject("parent").Add "id", folderid


    If SetNomarlParameter(tempParamStream, "attributes", JsonConverter.ConvertToJson(JsonObject)) Then
    End If

    If SetFileParmater(tempParamStream, "file", filepath, contentType) Then
    End If

    If SetEndParameter(tempParamStream) Then
    End If

    'リクエストパラメータを取得
    Dim snedParameter As Variant
    GetSendParameter snedParameter, tempParamStream

    'リクエストの送信
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open strMethod, strUri, False
        '.setProxy 2, proxyuri
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" + getBoundy(adBTypeContent)
        .setRequestHeader "Authorization", "Bearer " & access_token
        .send snedParameter
        
        '返ってきた値をもとにデータを処理
        Debug.Print .status
        Select Case .status
            Case 200, 201
                'レスポンスヘッダを取得
                Debug.Print .GetAllResponseHeaders()
                
                '投稿結果
                strResult = .responseText
                
                Debug.Print strResult

            Case Else
                MsgBox .status & "エラー。アップロードは失敗しました。"
        End Select
    End With

    '終了処理
    Set rs = Nothing
    Set db = Nothing
  
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

Public Function BoxUploadFile()

'変数の宣言

Dim ret As Variant

'DB接続用

Dim db As DAO.Database

Dim rs As DAO.Recordset

'Access Tokenの取得と失効チェック

Dim tokenstatus As Integer

tokenstatus = checkExpireToken()

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

Select Case tokenstatus

Case 0

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

Case 1

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

ret = getNewToken()

'取得結果を判定

If ret = True Then

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

Else

'取得失敗

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

Exit Function

End If

Case 2

'60日オーバーなので再認証をする

Call boxAuthorization

'終了処理

MsgBox "認証が期限切れです。再認証を実行してください。"

Exit Function

End Select

'Boxへ送信するファイルとその情報

Dim filepath As String: filepath = CurrentProject.Path & "\" & "database.xlsx"

Dim strMethod As String: strMethod = "POST"

Dim strUri As String

Dim strResult As String

'URLの組み立て

strUri = uploadpoint & fileid & "/content"

'ファイルのMIME TYPE

Dim contentType As String

contentType = "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"

'Access Tokenを取得する

Set db = CurrentDb()

Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)

Dim access_token As String

access_token = rs!access_token

'ADODBで領域確保

Dim tempParamStream As Object

Set tempParamStream = CreateObject("ADODB.Stream")

tempParamStream.Open

'リクエストパラメータを構築

Dim FileName As String

FileName = Dir(filepath)

Dim JsonObject As Object

Set JsonObject = New Dictionary

JsonObject.Add "name", FileName

JsonObject.Add "parent", New Dictionary

JsonObject("parent").Add "id", folderid

If SetNomarlParameter(tempParamStream, "attributes", JsonConverter.ConvertToJson(JsonObject)) Then

End If

If SetFileParmater(tempParamStream, "file", filepath, contentType) Then

End If

If SetEndParameter(tempParamStream) Then

End If

'リクエストパラメータを取得

Dim snedParameter As Variant

GetSendParameter snedParameter, tempParamStream

'リクエストの送信

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open strMethod, strUri, False

'.setProxy 2, proxyuri

.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + getBoundy(adBTypeContent)

.setRequestHeader "Authorization", "Bearer " & access_token

.send snedParameter

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

Debug.Print .status

Select Case .status

Case 200, 201

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

Debug.Print .GetAllResponseHeaders()

'投稿結果

strResult = .responseText

Debug.Print strResult

Case Else

MsgBox .status & "エラー。アップロードは失敗しました。"

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

End Function

アップロードは以前の記事にも記述しています。詳細は以下の記事を参照してみてください。
今回異なる点は、xlsxファイルであるので、contentTypeでのMIME Typeはapplication/vnd.openxmlformats-officedocument.spreadsheetml.sheetを指定する必要があります。
また、アップロードするファイルはダウンロード時のパスであるCurrentProject.Path & "¥database.xlsx"となります。

VBAからBox APIを叩いてみる – 実践編

editフォームロード時などのインメモリレコードセット

    Dim rstADO As ADODB.Recordset
    Dim fld As ADODB.Field
    
    'フィールドの設定
    Set rstADO = New ADODB.Recordset
    With rstADO
        .Fields.Append "ID", adInteger, , adFldKeyColumn
        .Fields.Append "インシデント名", adVarChar, 255, adFldMayBeNull
        .Fields.Append "日付", adDate
        .Fields.Append "タイプ", adVarChar, 64, adFldMayBeNull
        .Fields.Append "対象者", adVarChar, 64, adFldMayBeNull
        .Fields.Append "優先度", adInteger, , adFldMayBeNull
        .Fields.Append "インシデント内容", adVarChar, 255, adFldMayBeNull
        .Fields.Append "最終更新日", adBigInt, , adFldMayBeNull
    
        .CursorType = adOpenKeyset
        .CursorLocation = adUseClient
        .LockType = adLockPessimistic
        .Open
    End With
    
    'データの追加
    Dim dbs As DAO.Database
    Dim rstDAO As DAO.Recordset
    Dim strSQL As String
    
    Set dbs = CurrentDb
    strSQL = "select * from incident"
    Set rstDAO = dbs.OpenRecordset(strSQL, dbOpenDynaset)
    
    Do Until rstDAO.EOF
        rstADO.AddNew
            rstADO.Fields(0) = rstDAO!ID
            rstADO.Fields(1) = rstDAO!インシデント名
            rstADO.Fields(2) = rstDAO!日付
            rstADO.Fields(3) = rstDAO!タイプ
            rstADO.Fields(4) = rstDAO!対象者
            rstADO.Fields(5) = rstDAO!優先度
            rstADO.Fields(6) = rstDAO!インシデント内容
            rstADO.Fields(7) = rstDAO!最終更新日
        rstADO.Update
        
        rstDAO.MoveNext
    Loop
    
    'データソースの指定と終了処理
    Set Me.Recordset = rstADO
    Set rstDAO = Nothing
    Set dbs = Nothing

Dim rstADO As ADODB.Recordset

Dim fld As ADODB.Field

'フィールドの設定

Set rstADO = New ADODB.Recordset

With rstADO

.Fields.Append "ID", adInteger, , adFldKeyColumn

.Fields.Append "インシデント名", adVarChar, 255, adFldMayBeNull

.Fields.Append "日付", adDate

.Fields.Append "タイプ", adVarChar, 64, adFldMayBeNull

.Fields.Append "対象者", adVarChar, 64, adFldMayBeNull

.Fields.Append "優先度", adInteger, , adFldMayBeNull

.Fields.Append "インシデント内容", adVarChar, 255, adFldMayBeNull

.Fields.Append "最終更新日", adBigInt, , adFldMayBeNull

.CursorType = adOpenKeyset

.CursorLocation = adUseClient

.LockType = adLockPessimistic

.Open

End With

'データの追加

Dim dbs As DAO.Database

Dim rstDAO As DAO.Recordset

Dim strSQL As String

Set dbs = CurrentDb

strSQL = "select * from incident"

Set rstDAO = dbs.OpenRecordset(strSQL, dbOpenDynaset)

Do Until rstDAO.EOF

rstADO.AddNew

rstADO.Fields(0) = rstDAO!ID

rstADO.Fields(1) = rstDAO!インシデント名

rstADO.Fields(2) = rstDAO!日付

rstADO.Fields(3) = rstDAO!タイプ

rstADO.Fields(4) = rstDAO!対象者

rstADO.Fields(5) = rstDAO!優先度

rstADO.Fields(6) = rstDAO!インシデント内容

rstADO.Fields(7) = rstDAO!最終更新日

rstADO.Update

rstDAO.MoveNext

Loop

'データソースの指定と終了処理

Set Me.Recordset = rstADO

Set rstDAO = Nothing

Set dbs = Nothing

直接リンクテーブルをレコードソースにしない理由は、データ保存時に最新のExcelをダウンロードしてきてリンクを張り直す際に、上書きできなくなるため。その為、今回はincidentテーブルに直結せずインメモリのレコードセットをサブフォームに指定する為に、上記のコードを利用しています。
カラムを指定し、incidentテーブルの内容をメモリ上のrstADOに対してレコードを追加しています。

保存時のロジック

'データを保存する
Private Sub コマンド6_Click()
    '対象のxlsxがロックされているかどうかを確認
    Dim lockmode As String
    lockmode = boxlockchek()

    'ロックされていたら処理を中止
    If lockmode = "NG" Then
        MsgBox "ファイルは現在ロックされています"
        Exit Sub
    End If
    
    'ファイルをロックする
    Dim lockexec As Boolean
    lockexec = BoxFileLock()

    'ロックが成功したかどうかをチェックする
    If lockexec = True Then
        'ロック成功なので次の処理へ
    Else
        'ロック失敗時
        MsgBox "ファイルのロックに失敗しました"
        Exit Sub
    End If

    'リンクテーブルを貼り直し（ファイルも再ダウンロード）
    Call startupexe
    
    'サブフォームのレコードセットを更新
    Call setInmemory
    
    '1レコード追加する
    Dim AppObj As Object 'Excel.Applicationオブジェクトの宣言
    Dim WBObj As Object 'Excel.Workbookオブジェクトの宣言
    Dim WsObj As Object 'Excel.WorkSheetオブジェクトの宣言
    
    '書き込み先ファイルの指定
    Dim filepath As String
    filepath = CurrentProject.Path & "\database.xlsx"
    
    'ファイルを開く
    Set AppObj = CreateObject("Excel.Application") '実行時バインディング
    Set WBObj = AppObj.Workbooks.Open(filepath) 'ワークブックを開く
    Set WsObj = WBObj.Worksheets("Sheet1") '書き込み先シート名の指定
    
    'IDの最大値を取得 + 1加算
    Dim maxid As Variant
    maxid = DMax("ID", "incident")
    maxid = maxid + 1
    
    '現在の日時秒まで取得する
    Dim nowdate As Variant
    Dim tempdate As Variant
    Dim yearmonth As Variant
    Dim temptime As Variant
    Dim hourmin As Variant
    
    tempdate = Date
    yearmonth = Format(tempdate, "yyyymmdd")
    
    temptime = Time
    hourmin = Format(temptime, "hhmmss")
    
    '日時データを結合する
    nowdate = yearmonth & hourmin
    
    'テーブルに1行データを入れる
    With WBObj.ActiveSheet.ListObjects(1)
        .ListRows.Add (1)
        With .ListRows(1)
            .Range(1) = maxid
            .Range(2) = Me.inciname.Value
            .Range(3) = Me.incidate.Value
            .Range(4) = Me.incitype.Value
            .Range(5) = Me.incitarget.Value
            .Range(6) = Me.incipriority.Value
            .Range(7) = Me.incidescript.Value
            .Range(8) = nowdate
        End With
    End With
    
    'Excelを保存して閉じる
    WBObj.Save 'ワークブックを保存する
    WBObj.Close 'ワークブックを閉じる
    AppObj.Quit
    
    '終了処理
    Set AppObj = Nothing
    Set WBObj = Nothing
    Set WsObj = Nothing
    
    'アップロードの実行
    Call BoxUploadFile
    
    'ロックの解除
    Dim unlockbox As Boolean
    unlockbox = BoxFileUnLock()
    
    '解除に成功したかどうかをチェックする
    If unlockbox = True Then
        'ロックの解除に成功
    Else
        'ロック解除失敗時
        MsgBox "ファイルのロック解除に失敗しました"
        Exit Sub
    End If
    
    'データをクリアする
    With Me
        .inciname.Value = ""
        .incidate.Value = ""
        .incitype.Value = ""
        .incitarget.Value = ""
        .incipriority.Value = ""
        .incidescript.Value = ""
        .inciid.Value = ""
        .editflg.Value = ""
    End With
    
    'リンクテーブルを貼り直し（ファイルも再ダウンロード）
    Call startupexe
    
    'サブフォームのレコードセットを更新
    Call setInmemory

    '終了処理
    Set db = Nothing
    Set tb = Nothing

End Sub

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

'データを保存する

Private Sub コマンド6_Click()

'対象のxlsxがロックされているかどうかを確認

Dim lockmode As String

lockmode = boxlockchek()

'ロックされていたら処理を中止

If lockmode = "NG" Then

MsgBox "ファイルは現在ロックされています"

Exit Sub

End If

'ファイルをロックする

Dim lockexec As Boolean

lockexec = BoxFileLock()

'ロックが成功したかどうかをチェックする

If lockexec = True Then

'ロック成功なので次の処理へ

Else

'ロック失敗時

MsgBox "ファイルのロックに失敗しました"

Exit Sub

End If

'リンクテーブルを貼り直し（ファイルも再ダウンロード）

Call startupexe

'サブフォームのレコードセットを更新

Call setInmemory

'1レコード追加する

Dim AppObj As Object 'Excel.Applicationオブジェクトの宣言

Dim WBObj As Object 'Excel.Workbookオブジェクトの宣言

Dim WsObj As Object 'Excel.WorkSheetオブジェクトの宣言

'書き込み先ファイルの指定

Dim filepath As String

filepath = CurrentProject.Path & "\database.xlsx"

'ファイルを開く

Set AppObj = CreateObject("Excel.Application") '実行時バインディング

Set WBObj = AppObj.Workbooks.Open(filepath) 'ワークブックを開く

Set WsObj = WBObj.Worksheets("Sheet1") '書き込み先シート名の指定

'IDの最大値を取得 + 1加算

Dim maxid As Variant

maxid = DMax("ID", "incident")

maxid = maxid + 1

'現在の日時秒まで取得する

Dim nowdate As Variant

Dim tempdate As Variant

Dim yearmonth As Variant

Dim temptime As Variant

Dim hourmin As Variant

tempdate = Date

yearmonth = Format(tempdate, "yyyymmdd")

temptime = Time

hourmin = Format(temptime, "hhmmss")

'日時データを結合する

nowdate = yearmonth & hourmin

'テーブルに1行データを入れる

With WBObj.ActiveSheet.ListObjects(1)

.ListRows.Add (1)

With .ListRows(1)

.Range(1) = maxid

.Range(2) = Me.inciname.Value

.Range(3) = Me.incidate.Value

.Range(4) = Me.incitype.Value

.Range(5) = Me.incitarget.Value

.Range(6) = Me.incipriority.Value

.Range(7) = Me.incidescript.Value

.Range(8) = nowdate

End With

'Excelを保存して閉じる

WBObj.Save 'ワークブックを保存する

WBObj.Close 'ワークブックを閉じる

AppObj.Quit

'終了処理

Set AppObj = Nothing

Set WBObj = Nothing

Set WsObj = Nothing

'アップロードの実行

Call BoxUploadFile

'ロックの解除

Dim unlockbox As Boolean

unlockbox = BoxFileUnLock()

'解除に成功したかどうかをチェックする

If unlockbox = True Then

'ロックの解除に成功

Else

'ロック解除失敗時

MsgBox "ファイルのロック解除に失敗しました"

Exit Sub

End If

'データをクリアする

With Me

.inciname.Value = ""

.incidate.Value = ""

.incitype.Value = ""

.incitarget.Value = ""

.incipriority.Value = ""

.incidescript.Value = ""

.inciid.Value = ""

.editflg.Value = ""

End With

'リンクテーブルを貼り直し（ファイルも再ダウンロード）

Call startupexe

'サブフォームのレコードセットを更新

Call setInmemory

'終了処理

Set db = Nothing

Set tb = Nothing

End Sub

詳細な解説は次項の仕組みの項目で説明しています。
AccessからはExcelに直接書き込みが出来ないので、オートメーションを利用し、尚且テーブルに対して行追加と値のセットを行っています。
最新レコードを一番上にするために、テーブルに対してListRows.Addしています。
今回は新規追加だけですが、更新時用に対象のレコードが書き換えられていないか？をチェックするための最終更新日情報の日付データを生成し、テーブルに書き込んでいます（更新時はこの値をチェックして読み込み時と書き込み時で値が変わってないかをチェックするようにします）
書き込むIDは、リンクテーブルのincidentに対してDMaxで簡単に取得可能。+1した値が新規書き込み時のIDとなります。

実際のExcelファイルに対してロックを掛ける⇒書き込む⇒アップロード⇒ロックを解除する時間は、人間が手作業でやるにはあまりにも面倒な上に、時間が掛かるため、他者の手を止めてしまいますが、今回のプログラムの場合は、ロックを自動でコントロールし、掛かってる時間もアップロード時の一瞬なので、限りなくバッティングが発生しません。

また、手動でdatabase.xlsxは編集しないように運用が必要です（手動で行うからバッティングが発生するわけで）。本物のDBのように行単位ロックなどが出来ず、ファイル単位ロックになってしまいますが、簡易的な社内システムをこれで構築する事も可能になるのではないかと思います。

AccessでExcelを操作する

仕組み

今回のプログラムは以下のような手順でExcelファイルへの書き込みを行っています。

起動時に最新のExcelファイルをBox APIを使ってダウンロードしてくる
1.に対して、incidentという名前でリンクテーブルを自動で作成
editフォームを開くと、2.の内容を直接ではなくインメモリレコードセットに作成し、それをレコードセットとして開く（リンクテーブルとExcelファイルは掴んだままではない状態）
下の画面にはExcelの内容が列挙されています。
上部の画面で入力欄を埋めてから保存をクリックすると今回の最も重要な作業が開始されます。

さて、ここからのロジックはバッティングを避けてデータをアップロードする為のフローになりますが、以下のようなロジックになっています。

Box APIで対象のファイルがロックされているかを確認
ロックされていなければ、今一度最新のExcelデータをダウンロードして、リンクテーブルを更新。
同時にファイルに対して、Box APIでロックを掛ける（ダウンロードも不可にしています）
ExcelをAccessから操作し、テーブルに対して1行追加、フォーム上の値を追加
この時、リンクテーブルのID列の最大値をDMax関数で取得しておき、+1した値を取得しています。
Box APIを利用して、database.xlsxファイルをアップロードします。
Box APIを利用して、ファイルに対してのロック解除を実行します。
最後にもう一度最新版のExcelファイルをダウンロードして、再度リンクテーブルを更新します。

今回は、新規追加のみを対応させましたが、既存のレコードの更新や削除されてた場合の対応を追加する事で、Box上のExcelをデータベースとして複数名で読み書きするようなプログラムをVBAで構築することが可能です。

図：メインの入力画面

Box上のExcelファイルを競合させずに読み書きする

今回使用するファイル等

Box Driveの場合の問題点

事前準備

database.xlsxの配置

boxmerge.accdbの編集

認証の実行

ソースコードと解説

ファイルのロック状態を取得する

ファイルに対してロックする

ファイルのロックを解除する

ファイルのアップロード

editフォームロード時などのインメモリレコードセット

保存時のロジック

仕組み

関連リンク

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

Google Apps ScriptでSpreadsheet上の画像を一括取り出し【GAS】

VBAでOAuth2.0認証 - Windows11対応版

今回使用するファイル等

Box Driveの場合の問題点

事前準備

database.xlsxの配置

boxmerge.accdbの編集

認証の実行

ソースコードと解説

ファイルのロック状態を取得する

ファイルに対してロックする

ファイルのロックを解除する

ファイルのアップロード

editフォームロード時などのインメモリレコードセット

保存時のロジック

仕組み

関連リンク

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

Google Apps ScriptでSpreadsheet上の画像を一括取り出し【GAS】

VBAでOAuth2.0認証 - Windows11対応版

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