ソースコード表示テスト

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