2018年10月21日 / 最終更新日時 : 2021年12月30日 officeの杜 msoffice

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

前回、Box APIを叩くための準備を行いました。社内で使う事を想定しWinHTTPRequestでプロキシーを超える為の設定も含めて、準備の紹介を行いました。すでにAccess Tokenは取得ができているのと、リフレッシュトークンを使った再取得の方法も紹介しています。

今回は、このAccess Tokenを使って、Box APIの中でもよく使うであろう、アップロード・ダウンロード・名前の変更・ファイルの削除・ファイルのロックをしてみたいと思います。また、加えてこのAPIを利用したアプリの使い所を研究してみたいと思います。

1 今回使用するファイルとライブラリ
2 ソースコード
3 使い所を考える

今回使用するファイルとライブラリ

ソースコード

ファイルのダウンロード

ファイルのダウンロードでは、ファイルのIDが必要です。ファイルのIDとは、「https://app.box.com/file/306826865097」とあった場合の「306826865097」の部分。これを指定します。BoxではContent PickerというGoogle Picker APIのようなものも用意されていますが、VBAから使うには厳しいので、直で指定しておく必要があります。

'APIアクセス用エンドポイントURL
Private Const filepoint As String = "https://api.box.com/2.0/files/"

'ファイルダウンロード関数（CurrentProject.pathにダウンロード）
Public Function getFileDownload() As Boolean
    'DB接続用
    Dim SQL As String
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim ret As Variant

　　　 'バイナリファイル生成用
    Dim FileData() As Byte
    Dim FileNum As Long
    
    'ファイルのIDを指定
    Dim fileid As Variant
    fileid = "306826865097"

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

    'JSON受信用
    Dim Json As Variant
    Dim doc, jsn
    'HTMLDocumentを取得
    Set doc = CreateObject("HtmlFile")
    'scriptタグを追加
    doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
    
    'Tokenの状況に応じて処理を分岐
    Select Case tokenstatus
        Case 0
            '無事にTokenは生きてるので何もしない
        Case 1
            'refresh token使って新しいTokenを取得
            ret = getNewToken()
            
            '取得結果を判定
            If ret = True Then
                '無事に取得できているのでスルーする
            Else
                '取得失敗
                MsgBox "Access Tokenの取得に失敗しました。"
                getFileDownload = False
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            getFileDownload = False
            Exit Function
    End Select
    
    'Access Tokenを取得する
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token
    
    'フォルダ情報を取得する
    'POST通信でAPIを叩いてデータを取得
    Dim getinfourl As String
    Dim disposition As String
    Dim tempheader As Variant
    getinfourl = filepoint & fileid & "/content"

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", getinfourl, False
        '.setProxy 2, proxyuri  'プロキシサーバのURLとポート番号
        .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
                getFileDownload = False
        End Select
    End With
    
    '終了処理
    Set db = Nothing
    Set rs = Nothing
    
    getFileDownload = True
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

'APIアクセス用エンドポイントURL

Private Const filepoint As String = "https://api.box.com/2.0/files/"

'ファイルダウンロード関数（CurrentProject.pathにダウンロード）

Public Function getFileDownload() As Boolean

'DB接続用

Dim SQL As String

Dim db As DAO.Database

Dim rs As DAO.Recordset

Dim ret As Variant

　　　 'バイナリファイル生成用

Dim FileData() As Byte

Dim FileNum As Long

'ファイルのIDを指定

Dim fileid As Variant

fileid = "306826865097"

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

Dim tokenstatus As Integer

tokenstatus = checkExpireToken()

'JSON受信用

Dim Json As Variant

Dim doc, jsn

'HTMLDocumentを取得

Set doc = CreateObject("HtmlFile")

'scriptタグを追加

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

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

Select Case tokenstatus

Case 0

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

Case 1

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

ret = getNewToken()

'取得結果を判定

If ret = True Then

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

Else

'取得失敗

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

getFileDownload = False

Exit Function

End If

Case 2

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

Call boxAuthorization

'終了処理

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

getFileDownload = False

Exit Function

End Select

'Access Tokenを取得する

Set db = CurrentDb()

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

Dim access_token As String

access_token = rs!access_token

'フォルダ情報を取得する

'POST通信でAPIを叩いてデータを取得

Dim getinfourl As String

Dim disposition As String

Dim tempheader As Variant

getinfourl = filepoint & fileid & "/content"

With CreateObject("WinHttp.WinHttpRequest.5.1")

.Open "GET", getinfourl, False

'.setProxy 2, proxyuri 'プロキシサーバのURLとポート番号

.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

getFileDownload = False

End Select

End With

'終了処理

Set db = Nothing

Set rs = Nothing

getFileDownload = True

End Function

ファイル名の取得の行にて、帰ってくるファイル名（UTF8）をデコードする為に、DecodeURLMSHTMLという関数を利用しています。利用する為には、参照設定にて「Microsoft HTML Object Library」が必要です。
この項目の基本ですが、Tokenが生存してるかどうかの判定ルーチンにて、期限切れの場合リフレッシュトークンで取得し直し、ルーチンを続行させています。
ファイルはとりあえず、プログラムのある同じフォルダ内に生成されます。
ファイル名などの情報は、Content-Dispositionヘッダー内に含まれていて、ここから取り出します。ヘッダの内容は以下のような感じ
使用するエンドポイントURLは、https://api.box.com/2.0/files/となります。

Cache-Control: private
Connection: keep-alive
Date: Sun, 21 Oct 2018 01:21:27 GMT
Content-Length: 4283254
Content-Type: image/jpeg
Accept-Ranges: bytes
Age: 0
Content-Disposition: attachment;filename="P_20180722_165428.jpg";filename*=UTF-8''P_20180722_165428.jpg
X-Robots-Tag: noindex, nofollow
X-Content-Type-Options: nosniff
Strict-Transport-Security: max-age=31536000

Cache-Control: private

Connection: keep-alive

Date: Sun, 21 Oct 2018 01:21:27 GMT

Content-Length: 4283254

Content-Type: image/jpeg

Accept-Ranges: bytes

Age: 0

Content-Disposition: attachment;filename="P_20180722_165428.jpg";filename*=UTF-8''P_20180722_165428.jpg

X-Robots-Tag: noindex, nofollow

X-Content-Type-Options: nosniff

Strict-Transport-Security: max-age=31536000

ファイルのアップロード

Box APIで最も面倒なルーチンは、ファイルのアップロードです。バイナリデータを送らなければならないため、様々な処理を追加しなければなりません。そのため、送信パラメータが複雑です。フォルダのIDおよびファイルのID、ファイル名、MIMETYPEが必要となります。今回はjpgファイルを送り込むので、ファイルのMIMETYPEは「image/jpeg」となります。ZIPならば「application/x-compress」ですね。

今回この部分については、大変よくできたルーチンがありますので、こちらを利用しました。

Const adTypeBinary = 1
Const adTypeText = 2
Const adBTypeContent = 1
Const adBTypeBody = 2
Const adBTypeFooter = 3
Private Const uploadpoint As String = "https://upload.box.com/api/2.0/files/"

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 & "\" & "P_20180722_165428.jpg"
    Dim strMethod As String: strMethod = "POST"
    Dim strUri As String
    Dim strResult As String
    Dim folderid As Variant
    Dim fileid As Variant
    folderid = "51765426966"
    fileid = "306826865097"

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

    'ファイルのMIME TYPE
    Dim contentType As String
    contentType = "image/jpeg"

    '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
        
        '返ってきた値をもとにデータを処理
        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

117

118

119

120

121

122

123

124

Const adTypeBinary = 1

Const adTypeText = 2

Const adBTypeContent = 1

Const adBTypeBody = 2

Const adBTypeFooter = 3

Private Const uploadpoint As String = "https://upload.box.com/api/2.0/files/"

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 & "\" & "P_20180722_165428.jpg"

Dim strMethod As String: strMethod = "POST"

Dim strUri As String

Dim strResult As String

Dim folderid As Variant

Dim fileid As Variant

folderid = "51765426966"

fileid = "306826865097"

'URLの組み立て

strUri = uploadpoint & fileid & "/content"

'ファイルのMIME TYPE

Dim contentType As String

contentType = "image/jpeg"

'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

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

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

パラメータの構築では、SetNomarlParameter、SetFileParmater、SetEndParameter、GetSendParameter、ChangeStreamType、getBoundyをこちらのサイトのコードを利用させていただきました。
アップロードは上書きアップロードされます。バージョンが重なってる点で判別が可能です。
フォルダIDおよびファイルID、ファイルのパスは固定にしてしまってるので、ここを手直しする必要があります。
リクエストパラメータの設定に失敗すると文字化けしてアップロードされてしまいます。
HeaderリクエストにあるBoundaryとは、バウンダリ文字列と呼ばれるもので、適当な文字列なのですが、リクエスト文の境界線で用いられる文字列で必須です（文字種と文字数が一致していればUUIDのように生成して使って問題ない）。
ファイルの種類ごとにMIMETYPEは異なるので、より汎用的な関数にするには、拡張子などからMIMEを設定するルーチンが必要です。

図：ファイルの版がアップデートされてることを確認

名前の変更

ファイル・フォルダの名前の変更には、新しいファイル名、ファイル・フォルダのIDが必要になります。また、今回は一つの関数でファイルとフォルダのリネームに対応させているので、フラグも必要（0ならばファイルのリネーム、1ならばフォルダのリネーム）。

'エンドポイントURL
Private Const renamepoint As String = "https://api.box.com/2.0/files/"
Private Const renfolpoint As String = "https://api.box.com/2.0/folders/"

'BOX ファイル名変更ルーチン
Public Function BoxRename(flg As Integer, newname As String, fid As Variant) 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の取得に失敗しました。"
                BoxRename = False
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            BoxRename = False
            Exit Function
    End Select

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

    'URLの組み立て
    If flg = 0 Then
        'ファイルのリネーム
        strUri = renamepoint & fid
    Else
        'フォルダのリネーム
        strUri = renfolpoint & fid
    End If

    '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 "name", newname

    '送信リクエスト
    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 & "エラー。リネームは失敗しました。"
                BoxRename = False
                '終了処理
                Set rs = Nothing
                Set db = Nothing
                Exit Function
        End Select
    End With

    '終了処理
    Set rs = Nothing
    Set db = Nothing
    
    '値を返す
    BoxRename = True
    
End Function

100

101

102

103

104

105

'エンドポイントURL

Private Const renamepoint As String = "https://api.box.com/2.0/files/"

Private Const renfolpoint As String = "https://api.box.com/2.0/folders/"

'BOX ファイル名変更ルーチン

Public Function BoxRename(flg As Integer, newname As String, fid As Variant) 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の取得に失敗しました。"

BoxRename = False

Exit Function

End If

Case 2

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

Call boxAuthorization

'終了処理

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

BoxRename = False

Exit Function

End Select

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

Dim strMethod As String: strMethod = "PUT"

Dim strUri As String

Dim strResult As String

'URLの組み立て

If flg = 0 Then

'ファイルのリネーム

strUri = renamepoint & fid

Else

'フォルダのリネーム

strUri = renfolpoint & fid

End If

'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 "name", newname

'送信リクエスト

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 & "エラー。リネームは失敗しました。"

BoxRename = False

'終了処理

Set rs = Nothing

Set db = Nothing

Exit Function

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

'値を返す

BoxRename = True

End Function

引数のflgでファイルのリネームか？フォルダのリネームかを判定しています。
ファイルとフォルダとで、それぞれ利用するエンドポイントURLが異なります。
ファイルの場合のエンドポイントURLは、https://api.box.com/2.0/files/となります。フォルダの場合のエンドポイントURLは、https://api.box.com/2.0/folders/となります。
パラメータの構築はJSON形式で作って送ってあげる必要があるため、VBA-JSONのJsonConverterを利用しています。
WinHTTPRequestでの送信メソッドは「PUT」ですので注意が必要です。

ファイルの削除

ファイルの削除はファイルのIDがあれば問題ありません。こちらも１つの関数でファイルとフォルダの削除に対応させているので、flgを引数に与えています。

'エンドポイントURL
Private Const renamepoint As String = "https://api.box.com/2.0/files/"
Private Const renfolpoint As String = "https://api.box.com/2.0/folders/"

'BOX ファイル削除ルーチン
Public Function BoxDelete(flg As Integer, fid As Variant) 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の取得に失敗しました。"
                BoxDelete = False
                Exit Function
            End If
        Case 2
            '60日オーバーなので再認証をする
            Call boxAuthorization
            
            '終了処理
            MsgBox "認証が期限切れです。再認証を実行してください。"
            BoxDeleteFile = False
            Exit Function
    End Select

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

    'URLの組み立て
    If flg = 0 Then
        strUri = renamepoint & fid
    Else
        strUri = renfolpoint & fid & "?recursive=true"
    End If
    
    'Access Tokenを取得する
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("tokeninfo", dbOpenDynaset)
    Dim access_token As String
    access_token = rs!access_token

    '送信リクエストを送る
    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, 204
                'レスポンスヘッダを取得
                Debug.Print .GetAllResponseHeaders()
                
                '投稿結果
                strResult = .responseText
                
                Debug.Print strResult

            Case Else
                MsgBox .status & "エラー。削除は失敗しました。"
                BoxDelete = False
                '終了処理
                Set rs = Nothing
                Set db = Nothing
                Exit Function
        End Select
    End With

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

End Function

'エンドポイントURL

Private Const renamepoint As String = "https://api.box.com/2.0/files/"

Private Const renfolpoint As String = "https://api.box.com/2.0/folders/"

'BOX ファイル削除ルーチン

Public Function BoxDelete(flg As Integer, fid As Variant) 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の取得に失敗しました。"

BoxDelete = False

Exit Function

End If

Case 2

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

Call boxAuthorization

'終了処理

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

BoxDeleteFile = False

Exit Function

End Select

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

Dim strMethod As String: strMethod = "DELETE"

Dim strUri As String

Dim strResult As String

'URLの組み立て

If flg = 0 Then

strUri = renamepoint & fid

Else

strUri = renfolpoint & fid & "?recursive=true"

End If

'Access Tokenを取得する

Set db = CurrentDb()

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

Dim access_token As String

access_token = rs!access_token

'送信リクエストを送る

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, 204

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

Debug.Print .GetAllResponseHeaders()

'投稿結果

strResult = .responseText

Debug.Print strResult

Case Else

MsgBox .status & "エラー。削除は失敗しました。"

BoxDelete = False

'終了処理

Set rs = Nothing

Set db = Nothing

Exit Function

End Select

End With

'終了処理

Set rs = Nothing

Set db = Nothing

'値を返す

BoxDelete = True

End Function

ほぼファイルのリネームと同じルーチンですが、エンドポイントURLにつなげる項目がフォルダの場合の削除は少々異なります。
WinHTTPRequestでの送信メソッドは「DELETE」ですので注意が必要です。
特に送信にあたってリクエスト文を組み立てる必要がないのでシンプルですね。

ファイルのロック

ファイルのロックはロックしている最中はファイルのダウンロードを阻止したり、編集の禁止をさせる為のものです。GUI上では誰でも簡単にロックは外せてしまうので、強力なものではないのですが、社内で使う上では必須です。ロックを掛けずにファイルの上書きがバッティングすると、あとから上書きしたファイルはファイルの整合性がズレ、別ファイルとして分離されてしまう仕組みなので、このロックは有効活用すべきですね。

'エンドポイントURL
Private Const renamepoint As String = "https://api.box.com/2.0/files/"

'Boxのファイルをロックもしくは解除するルーチン
Public Function BoxFileLock(fid As Variant) 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 = renamepoint & fid

    '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 "expires_at", "2018-10-05T0:00:00+09:00" 'グリニッジ標準時に9時間加算させてある
    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

100

101

'エンドポイントURL

Private Const renamepoint As String = "https://api.box.com/2.0/files/"

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

Public Function BoxFileLock(fid As Variant) 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 = renamepoint & fid

'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 "expires_at", "2018-10-05T0:00:00+09:00" 'グリニッジ標準時に9時間加算させてある

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

パラメータの構築はJSON形式で作って送ってあげる必要があるため、VBA-JSONのJsonConverterを利用しています。
パラメータ上、いつまでロックするか？の時間は、そのままではexpire_atの時刻はGMTなのでここに常に9時間を足した時間で指定しないと、日本ではおかしなロックになってしまいます。
今回のルーチンでは、expire_atの時刻指定（何時間後まで）の部分はしっかり作っていないので、実用する場合は、少し手直しが必要です。
WinHTTPRequestでの送信メソッドは「PUT」ですので注意が必要です。
ファイルに対してしかロックはできません。
is_download_preventedはFalseですとファイルのダウンロードもロックします。
今回のメソッドはDictionaryオブジェクトを利用しているので、参照設定として「Microsoft Scripting Runtime」が必要です。
アンロックする場合は、JsonObjectにAddする部分で、JsonObject(“lock”).Add nullでアンロックになるとのこと。

使い所を考える

実際にBox上では、Box editを使えばExcelファイルを開ける！また、保存した時に自動的に同期するといった謳い文句がありますが、まぁ、バグが酷いです。Box Toolが入ってるにも関わらず、Excelを開くアプリケーションが無い（実際には入ってる）と言われたり、同期ミスったり、PCを起動する度に勝手にファイルが増殖するなど、ちょっと使い物になりません。

また、Box DriveというGoogle Drive File Streamと同じような機能の仕組みもあるのですが、古い企業ではネットワークトラフィックが耐えられなかったり、プロキシーサーバ経由の場合不具合が出るなどの理由で、利用が制限されていることもあります。それ故ファイルサーバの代わりにはならず、そうなると「Excelのファイル間リンク」「Wordの差し込み印刷」などいった機能が使えなくなります。APIを利用することでこれらをカバーすることが可能です。

共有してみる：