作成: 2017.08.15 更新: 2021.03.05

はじめに
ファイルを送信するには
実際にEXCEL(VBA)からHTTP通信にて画像等のファイルを送信
- ■サンプルプログラム
- 送信パラメタの生成の経過
まとめ

この記事はアピリッツの技術ブログ「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送信する処理を考えてみようと思っています。