ファイルのアップロードで嵌った話・・・
バックログのAPIでWikiページや課題の詳細にファイル添付するためのやり取りがある。それを実装しようとして３，４日嵌ったことがある。
結論としては以下の条件を守れば文字化けとかもなくバイナリーファイルをアップロードできることがわかった。
１．マルチパートのデータの日本語ファイル名の部分をUTF-8に変換して設定しないとサーバーエラーになってしまうことが分かった。
２．ADODBを使えばクリアできると思ったが何が悪いのかは確定していないがSJISでないとうまくいかなかった。
３．SJISで実施すると送付自体はうまくいくがファイル名が文字化けしてしまうことになった。そこでURLエンコードでファイル名を変換して送ってもサーバ側はデコードしてくれなくてがっかりだった。
４．最終的にヌーラボ社へ問合せてサンプルコードが欲しいといったらpysonスクリプトを送ってくれた。中身を調べるとやはりテキスト部分はUTF-8へ変換するのにバイト配列で設定する方式だった。
５．最終的にそれをVBAで真似をしたら上手くいきました。
暫くぶりでソースコード貼り付けたら上手く変換してくれなくて困った・・・
「編集みたまま」の隣のタブ「HTML編集」でソースコードを以下のタグで挟んでやれば上手くいくことが分かった。
<pre class="code VBA" data-lang="VBA" data-unlink>
ここにソースコードを直接入れる
</pre>
Sub TestUploadFile()
Dim rstr As String
Dim rstr2 As String
Dim file_path As String
'Debug.Print "UploadFile"
file_path = ThisWorkbook.Path & "\" & "猫アイコン128x128.png"
rstr = UploadFile(file_path, "猫アイコン128x128.png")
Dim jsonObj As Object
Set jsonObj = ParseJson(rstr)
Debug.Print jsonObj("id")
Debug.Print jsonObj("name")
Debug.Print jsonObj("size")
' Debug.Print "DBODB_UploadFile"
' rstr2 = UploadFile_NoBOM(file_path, "猫アイコン128x128.png")
' Set jsonObj = ParseJson(rstr2)
' Debug.Print jsonObj("id")
' Debug.Print jsonObj("name")
' Debug.Print jsonObj("size")
End Sub
Public Function UploadFile(file_path, file_name) As String
If C_UPLOAD_CNT >= 500 Then
MsgBox "アップロード回数が500に達しました。システム制限によりこれ以上はアップロードできません！"
UploadFile = "UPLOAD LIMIT 500"
Exit Function
End If
Dim WS1 As Worksheet
Set WS1 = □基本設定
Dim spaURL As String
Dim apiURL As String
Dim apiKey As String
spaURL = WS1.Range("B3")
apiKey = WS1.Range("B4")
apiURL = "/api/v2/space/attachment"
Dim Url As String
Url = spaURL & apiURL & "?" & "apiKey" & "=" & apiKey
' ファイルの情報設定
Dim mimeType As String
mimeType = "application/octet-stream" 'ファイルのmime-type
Const adTypeBinary = 1
Const adTypeText = 2
Dim BOUNDARY As String
Dim END_BOUNDARY As String
BOUNDARY = "---------------------------BOUNDARY"
END_BOUNDARY = vbCrLf & "--" & BOUNDARY & "--" & vbCrLf & vbCrLf
'1. アップロードするファイルを読みだす
Dim fileContents
Dim stream: Set stream = CreateObject("ADODB.Stream")
stream.Type = adTypeBinary
stream.Open
stream.LoadFromFile file_path
fileContents = stream.Read
stream.Close
'2. マルチパートのデータ構成手順の記述
Dim params As String: params = ""
params = params & "--" & BOUNDARY & vbCrLf
params = params & "Content-Disposition: form-data; name=""" & "file" & """;"
params = params & " filename=""" & file_name & """" & vbCrLf
params = params & "Content-Type: " & mimeType & vbCrLf & vbCrLf
'VBA内部はUNIコードなのでUTF-8への変換を実行
Dim aByte() As Byte
aByte = ToUTF8(params)
' バイナリデータの前まで
stream.Open
stream.position = 0
stream.Type = adTypeBinary
stream.Write aByte
' バイナリデータ
stream.Write fileContents
' 最後
aByte = ToUTF8(END_BOUNDARY)
stream.Write aByte
Dim formData
ChangeStreamType stream, adTypeBinary
stream.position = 0
formData = stream.Read
stream.Close
' HTTPSリクエスト
Dim http As New MSXML2.XMLHTTP60
http.Open "POST", Url, False
http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & BOUNDARY
http.send formData
If http.Status <> 200 Then
Dim errCnt As Long
errCnt = errCnt + 1
If errCnt < 2 Then
MsgBox ("HTTP エラー " & http.Status & " " & http.statusText)
End If
Debug.Print Format(Now(), "yyyy/mm/dd hh:mm:ss ") & http.ResponseText & " " & http.Status & " " & http.statusText
End If
C_UPLOAD_CNT = C_UPLOAD_CNT + 1
UploadFile = http.ResponseText
End Function
Function ChangeStreamType(stream, t)
Dim p As Long
p = stream.position
stream.position = 0
stream.Type = t
stream.position = p
Set ChangeStreamType = stream
End Function
