この記事はアピリッツの技術ブログ「DoRuby」から移行した記事です。情報が古い可能性がありますのでご注意ください。
はじめに
EXCEL(VBA)で、JSONデータをHTTP通信する方法に関しては、前回の記事を参考して下さい。
EXCELでファイルリストを管理し、PCに格納しているファイルもアップロード出来れば、作業効率が図れると思ったのがキッカケです。
それを実現する簡単な方法をご紹介します。
※実際は、そんなに簡単ではありませんでした（汗）
参考にさせて頂いたサイト
・WSH + VBScriptでのサンプルを参照して下さい。
・boundaryに関してのこちらの仕様を参照して下さい。
ファイルを送信するには
1.まずHTMLを使ったファイルを送信する処理を確認してみる
ファイルを送信するHTMLは、以下のようになります。enctype="multipart/form-data" を付ける事でファイルを送信することが可能となるのです。
<form action="http://localhost:8080/" method="POST" enctype="multipart/form-data">
<input type="text" name="id" /><br />
<input type="text" name="description" /><br />
<input type="file" name="file" /><br />
<input type="submit" name="submit" value="send"/>
</form>
HTMLイメージ
選択しているテキストファイルの内容
※使用しているサクラエディタは、こちら
2.HTTP通信の内容はどうなるの？
HTMLのフォームを使ったファイルアップロードの仕様はRFC1867を参照して下さい。
実際に送信し、proxyツールfiddler を使った、HTTP通信内容を確認した様子が以下の図となります。
※HTTPの構文に関しては、こちらのページが参考になります。
HTTPヘッダ部分の content-Type が、 multipart/form-data となっていますね。
ここでポイントとなるのは、 boundary= に設定されている”境界線”です。
3.multipart/form-data の構造
詳しくはこちらのサイトを参照して下さい。その中の一部を抜粋して説明します。
■HTTPヘッダ部
boundaryは、1文字以上70文字以下でなければなりません。
ブラウザによっては、40文字程度の場合もあります。
■ボディ部
ボディ部は、以下の3種類に分類されています。
フォームデータ（赤枠参照）
boundary は、先頭に--＋HTTPヘッダのboundary＋CRLF
ファイルデータ（バイナリデータも同様）（赤枠参照）
boundary は、先頭に--＋HTTPヘッダのboundary＋CRLF
フッタ（赤枠参照）
boundary は、先頭に--＋HTTPヘッダのboundary＋後尾に--＋CRLF
実際にEXCEL(VBA)からHTTP通信にて画像等のファイルを送信
実際簡単ではなかったポイントが、送信するファイルが、テキストではなく画像やEXCELファイル等のバイナリデータの場合です。
送信するmultipart/form-dataパラメタが、テキストであればString型の結合で対応できるのですが、画像やEXCELファイルはByte型になり、容易にはString型とByte型の結合ができませんでした。
解決方法として、上部でも記載さしている参考サイトと同様に、ファイル操作等に使用するADODB.Streamをパラメタ生成用の領域として使用することで、String型とByte型結合を実現しています。
ちなみに、今回もJSONを生成している部分は、こちらを使用させて頂いて居ます。
■サンプルプログラム
①メイン処理
Const adTypeBinary = 1
Const adTypeText = 2
Const adBTypeContent = 1
Const adBTypeBody = 2
Const adBTypeFooter = 3
Public Function UploadFile() As Boolean
Dim FilePath As String: FilePath = "d:\証明写真サンプル.jpg"
Dim strMethod As String: strMethod = "POST"
Dim strUri As String: strUri = "http://localhost"
Dim strResult As String
'---------------------------------
' リクエストパラメタ用の領域を生成
'---------------------------------
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", 0
If SetNomarlParameter(tempParamStream, "attributes", JsonConverter.ConvertToJson(JsonObject)) Then
End If
If SetFileParmater(tempParamStream, "file", FilePath, "application/octet-stream") Then
End If
If SetEndParameter(tempParamStream) Then
End If
'---------------------------------
' リクエストパラメタ取得
'---------------------------------
Dim snedParameter As Variant
GetSendParameter snedParameter, tempParamStream
'---------------------------------
' リクエスト
'---------------------------------
Dim objHTTP As Object
Set objHTTP = CreateObject("msxml2.xmlhttp")
objHTTP.Open strMethod, strUri, False
objHTTP.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + getBoundy(adBTypeContent)
objHTTP.send snedParameter
statusCode = objHTTP.status
strResult = StrConv(objHTTP.responsebody, vbUnicode)
Set objHTTP = Nothing
UploadFile = True
End Function
②データフォームのパラメタ設定
Private Function SetNomarlParameter( _
ByRef tempParamStream As Object, _
ByVal fname As String, _
ByVal fvalue As String) As Boolean
If fvalue <> "" Then
ChangeStreamType tempParamStream, adTypeText
Dim params As String
params = ""
params = params + getBoundy(adBTypeBody)
params = params + "Content-Disposition: form-data; name=""" + fname + """" + vbCrLf
params = params + vbCrLf
params = params + fvalue + vbCrLf
tempParamStream.WriteText params
End If
SetNomarlParameter = True
End Function
③ファイル（バイナリデータ）のパラメタ設定
Private Function SetFileParmater( _
ByRef tempParamStream As Object, _
ByVal fname As String, _
ByVal fvalue As String, _
ByVal fct As String) As Boolean
'-------------------------------------
' テキストデータ
'-------------------------------------
ChangeStreamType tempParamStream, adTypeText
Dim params As String
params = ""
params = params + getBoundy(adBTypeBody)
params = params + "Content-Disposition: form-data; name=""" + fname + """; filename=""" + fvalue + """" + vbCrLf
params = params + "Content-Type: " + fct + vbCrLf
params = params + vbCrLf
tempParamStream.WriteText params
'-------------------------------------
' バイナリデータ
'-------------------------------------
ChangeStreamType tempParamStream, adTypeBinary
Dim fileStream As Object
Set fileStream = CreateObject("ADODB.Stream")
fileStream.Type = adTypeBinary
fileStream.Open
fileStream.LoadFromFile fvalue
tempParamStream.Write fileStream.Read()
fileStream.Close
Set fileStream = Nothing
SetFileParmater = True
End Function
④フッタのパラメタ設定
Private Function SetEndParameter( _
ByRef tempParamStream As Object) As Boolean
ChangeStreamType tempParamStream, adTypeText
tempParamStream.WriteText getBoundy(adBTypeFooter)
SetEndParameter = True
End Function
⑤送信するパラメタを取得
Private Function GetSendParameter( _
ByRef parameter As Variant, _
ByRef stream As Object) As Boolean
ChangeStreamType stream, adTypeBinary
stream.Position = 0
parameter = stream.Read
stream.Close
Set stream = Nothing
GetSendParameter = True
End Function
⑥パラメタ用の領域の状態を変更する
最初に、p = stream.Positionで現在のポジションを取得しているのは、状態を変更したことでポジションが変わってしまうためです。
Private Function ChangeStreamType( _
ByRef stream As Object, _
ByVal adType As Integer) As Boolean
Dim p As Long
p = stream.Position
stream.Position = 0
stream.Type = adType
If adType = adTypeText Then
stream.Charset = "UTF-8"
End If
stream.Position = p
ChangeStreamType = True
End Function
⑦Boundy 情報取得
Boundyは、同じ文字列を使用することになるので、変数をstaticにすることで、１度生成した文字列を使って、用途に合わせたBoundyデータを復帰するようにしています。
各種参考させて頂いたサイトでは、Boundyデータは固定の文字列としていますが、折角なのでランダム文字列を生成＋年月日時分秒までを追加した文字列生成するようにしてみました。
Private Function getBoundy(ByVal adType As Integer) As String
Static sBoundy As String
If sBoundy = "" Then
Dim multipartChars As String: multipartChars = "-_1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim boundary As String: boundary = "--------------------"
Dim i, point As Integer
For i = 1 To 20
Randomize
point = Int(Len(multipartChars) * Rnd + 1)
boundary = boundary + Mid(multipartChars, point, 1)
Next
sBoundy = boundary + Format(Now, "yyyymmddHHMMSS")
End If
Select Case adType
Case adBTypeContent
getBoundy = sBoundy
Case adBTypeBody
getBoundy = "--" + sBoundy + vbCrLf
Case adBTypeFooter
getBoundy = vbCrLf + "--" + sBoundy + "--" + vbCrLf
End Select
End Function
送信パラメタの生成の経過
サンプルプログラムでは、"d:\証明写真サンプル.jpg" と画像ファイルを指定していますが
説明しやすいように、別のバイナリファイル（d:\test.bin）を用意して生成過程を確認してみます。
テキストデータを設定する場合には、tempParamStreamをテキスト状態に変更し
ファイル（バイナリデータ）を結合する場合には、tempParamStreamをバイナリ状態に変更することで結合（パラメタを生成）を実現します。
test.bin の内容
テキストパラメタ設定時
If SetNomarlParameter(tempParamStream, "attributes", JsonConverter.ConvertToJson(JsonObject)) Then
End If
上記を実行したタイミングでは、tempParamStreamのは以下の通り
※先頭の0xEF 0xBB 0xBF はBOM付き(UTF-8)の場合を表すコードとなります。
ファイルパラメタ設定時
If SetFileParmater(tempParamStream, "file", FilePath, "application/octet-stream") Then
End If
上記を実行したタイミングでは、tempParamStreamのは以下の通り
フッタまで設定時
If SetEndParameter(tempParamStream) Then
End If
上記を実行したタイミングでは、tempParamStreamのは以下の通り
まとめ
BOX API にて、もしもEXCEL(VBA)でファイルをアップロードさせるには今回の作成した処理を使って送信することが出来るはずです。
という事で、次回は、またBOX API に戻りPOST送信する処理を考えてみようと思っています。
