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