Box上のExcelファイルを競合させずに読み書きする
クラウドストレージのBox、とりわけBox Driveを利用していると頻繁に遭遇するのが「ファイルの競合」。つまり、複数名でファイルに上書きを行うとデータの整合性がなくなり、片方のファイルはオリジナルから分離されて、コピーとして別ファイル化され、後でトラブルになるというパターンです。
ファイルサーバでは無いので、複数名で同時に開いて同時に編集といったことは、Microsoft365のExcel Online Business(有償)があればウェブ上で可能と言えば可能ですが、無い・許可されていない、またブック間リンクやらAccessのリンクテーブルで利用などが理由で、Box Driveを使ってる場合だと避けがたい問題です。
という事で今回、Box APIを利用してこれを回避しつつ複数名で書き込みができないか挑戦してみました。時間が出来たら、更新時の処理や削除時の対策なども追加しようと思います。
目次
今回使用するファイル等
- Boxmerge - 書き込み用のAccessプログラム
- database.xlsx - 書き込み先のBoxに配置するExcelファイル
- Box API
- VBA-JSON
今回の記事は過去に公開済みの以下のエントリーをベースに進めていますので、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を取得しておきます。
この後、プログラム内でこの2つの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
- 標準の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
- 以前の記事にも記述した、ロックを掛けるコード。但し今回は無期限でロックを掛けるので、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
- ロックを掛ける場合と殆どコードは同じ
- 異なる点は、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
- アップロードは以前の記事にも記述しています。詳細は以下の記事を参照してみてください。
- 今回異なる点は、xlsxファイルであるので、contentTypeでのMIME Typeはapplication/vnd.openxmlformats-officedocument.spreadsheetml.sheetを指定する必要があります。
- また、アップロードするファイルはダウンロード時のパスであるCurrentProject.Path & "¥database.xlsx"となります。
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
- 直接リンクテーブルをレコードソースにしない理由は、データ保存時に最新の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
- 詳細な解説は次項の仕組みの項目で説明しています。
- AccessからはExcelに直接書き込みが出来ないので、オートメーションを利用し、尚且テーブルに対して行追加と値のセットを行っています。
- 最新レコードを一番上にするために、テーブルに対してListRows.Addしています。
- 今回は新規追加だけですが、更新時用に対象のレコードが書き換えられていないか?をチェックするための最終更新日情報の日付データを生成し、テーブルに書き込んでいます(更新時はこの値をチェックして読み込み時と書き込み時で値が変わってないかをチェックするようにします)
- 書き込むIDは、リンクテーブルのincidentに対してDMaxで簡単に取得可能。+1した値が新規書き込み時のIDとなります。
実際のExcelファイルに対してロックを掛ける⇒書き込む⇒アップロード⇒ロックを解除する時間は、人間が手作業でやるにはあまりにも面倒な上に、時間が掛かるため、他者の手を止めてしまいますが、今回のプログラムの場合は、ロックを自動でコントロールし、掛かってる時間もアップロード時の一瞬なので、限りなくバッティングが発生しません。
また、手動でdatabase.xlsxは編集しないように運用が必要です(手動で行うからバッティングが発生するわけで)。本物のDBのように行単位ロックなどが出来ず、ファイル単位ロックになってしまいますが、簡易的な社内システムをこれで構築する事も可能になるのではないかと思います。
仕組み
今回のプログラムは以下のような手順で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で構築することが可能です。
図:メインの入力画面



