VBAでPDFファイルをチャットワークにアップロードしたい

Question

前提・実現したいこと

こんにちは。初めて質問させていただきます。
会社で事務をしている非エンジニアです。

Excelのマクロを利用して、ローカルにあるPDFファイル（請求書）をchatworkにアップロードしようとしています。
ボタンを押したら下記uploadFile()が実行され、Excelと同じフォルダにあるPDFファイルをchatworkにアップロードしたいと思っています。

発生している問題・エラーメッセージ

レスポンスでファイルIDが返ってきますが、該当のチャットにはファイルがアップロードされていません。
コード上でもエラーメッセージはなく正常に終了します。
問題の特定、切り分けができず投稿させていただきました。

該当のソースコード

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 = ThisWorkbook.Path & "\請求書" & ".pdf"
    Dim ROOM_ID As String: ROOM_ID = ｛roomID｝
    Dim strMethod As String: strMethod = "POST"
    Dim strUri As String: strUri = "https://api.chatwork.com/v2/rooms/" & ROOM_ID & "/files"
    Dim API_TOKEN As String: API_TOKEN = {APITOKEN}
    Dim strResult As String

    '---------------------------------
    '　リクエストパラメタ用の領域を生成
    '---------------------------------
    Dim tempParamStream As Object
    Set tempParamStream = CreateObject("ADODB.Stream")
    tempParamStream.Open

    '---------------------------------
    '　リクエストパラメタ作成
    '---------------------------------
    Dim filename As String
    filename = Dir(FilePath)

    If SetFileParmater(tempParamStream, "file", filename, "application/pdf", FilePath) Then
    End If

    If SetEndParameter(tempParamStream) Then
    End If

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

    '---------------------------------
    ' リクエスト
    '---------------------------------
    Dim objHTTP As XMLHTTP60
    Set objHTTP = New XMLHTTP60
    objHTTP.Open strMethod, strUri, False
    objHTTP.setRequestHeader "Content-Type", "multipart/form-data; boundary=" + getBoundy(adBTypeContent)
    objHTTP.setRequestHeader "X-ChatWorkToken", API_TOKEN
    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 + """" + "; filename=" + fvalue + 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, _
                            ByVal fpath) 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 fpath

    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

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

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 16
            Randomize
            point = Int(Len(multipartChars) * Rnd + 1)
            boundary = boundary + Mid(multipartChars, point, 1)
        Next

        sBoundy = boundary

    End If

    Select Case adType
    Case adBTypeContent
        getBoundy = sBoundy
    Case adBTypeBody
        getBoundy = "--" + sBoundy + vbCrLf
    Case adBTypeFooter
        getBoundy = vbCrLf + "--" + sBoundy + "--" + vbCrLf
    End Select

End Function

試したこと

こちらを参考にさせていただき、作成しました。
EXCEL(VBA)から、HTTP通信でファイルをアップロードしてみよう。
chatwork API ドキュメント
エクセルVBAでチャットワークに最もシンプルなメッセージを送る方法

同様の問題が発生していると思われるこちらの方を参考に、SetFileParmater()とgetBoundy()の
vbCrLfの数をを減らしてみましたが動作は変わりませんでした。
chatwork-ruby v0.10.0をリリースした

補足情報（FW/ツールのバージョンなど）

Windows10 Home 64bit
Microsoft Office 365 Business

VBAで追加した参照設定

• Microsoft Scripting Runtime
• MicrosoftXML v6.0

Answer 1

ChangeStreamTypeの
stream.Charset = "UTF-8"
を
stream.Charset = "Shift-JIS"
にしたらアップロードされました。

また、getBoundyでの乱数で作成したpointの値が0の場合にエラーになるのでそれを回避する処理が必要でした。

Comments

[jimuinA]

ありがとうございます！
無事PDFファイルをアップロードできました。
大変助かりました。

追加でもしお分かりになられましたら教えてください。
アップロードした際、ファイル名が「請求書.pdf」とはならず
「??????.pdf 」といった名前に文字化けしてしまいました。

filename = Dir(FilePath)　の後に
filename = Asc(filename) の1行を追加し、文字コードの変換を行ってみたのですが解決しませんでした。

どうぞよろしくお願いいたします。

[jimuinA]

お騒がせしてすみませんでした。

以下を変更し、自己解決しました。
（PDFのファイル名をURLエンコードして対応しました。）

１．uploadFileに１行追加
変更前
filename = Dir(FilePath)

変更後
filename = Dir(FilePath)
filename = Application.WorksheetFunction.EncodeURL(filename) '←この一文を追加

２．SetFileParmaterの内容を変更
変更前
params = params + "Content-Disposition: form-data; name=""" + fname + """; filename=""" + fvalue + """" + vbCrLf

変更後
params = params + "Content-Disposition: form-data; name=""" + fname + """; filename*=utf-8''" + fvalue + vbCrLf

参考にさせていただいた記事
https://qiita.com/khsk/items/d541b8dc40bd2c6128d2
https://www.ka-net.org/blog/?p=1938

[HANAMIZAKE]

無事アップできたようで良かったです。
私も一から作るのが手間だと思っていたときに本記事を見つけたので助かりました。
ありがとうございました。