Upload image to file.io with VBA (almost working)

[paun_shotts]

Hi,

I have some VBA code that uploads a file to files.io, I am then given a response, which includes the download link.
The issue is that when I download the file, the image cannot be viewed by any app that I have tried.
I tried uploading a .txt file, and when I downloaded the file, it was blank.
I have tried .jpeg .jpg .txt but none of the files are able to be viewed properly after downloading.

Here is my code:

Sub UploadFilesUsingVBA()
'this proc will upload below files to https://file.io/
'  png, jpg, txt


    Dim fileFullPath As String
    fileFullPath = "C:\Users\shaun\Documents\Sports Betting\NFL\Daily Bets\20231114.png"

    POST_multipart_form_data fileFullPath
End Sub

Private Function GetGUID() As String
' Generate uuid version 4 using VBA
GetGUID = WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 4294967295#), 8) & "-" & _
        WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 65535), 4) & "-" & _
        WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(16384, 20479), 4) & "-" & _
        WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(32768, 49151), 4) & "-" & _
        WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 65535), 4) & _
        WorksheetFunction.Dec2Hex(WorksheetFunction.RandBetween(0, 4294967295#), 8)

End Function


Private Function GetFileSize(fileFullPath As String) As Long


Dim lngFSize As Long, lngDSize As Long
Dim oFO As Object, OFS As Object

lngFSize = 0
Set OFS = CreateObject("Scripting.FileSystemObject")

If OFS.FileExists(fileFullPath) Then
    Set oFO = OFS.getFile(fileFullPath)
    GetFileSize = oFO.Size
Else
    GetFileSize = 0
End If

Set oFO = Nothing
Set OFS = Nothing

End Function


Private Function ReadBinary(strFilePath As String)
Dim ado As Object, bytFile
Set ado = CreateObject("ADODB.Stream")
ado.Type = 1
ado.Open
ado.LoadFromFile strFilePath
bytFile = ado.Read
ado.Close


ReadBinary = bytFile

Set ado = Nothing

End Function


Private Function toArray(str)
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Type = 2
ado.Charset = "_autodetect"
ado.Open
ado.WriteText (str)
ado.Position = 0
ado.Type = 1
toArray = ado.Read()
Set ado = Nothing
End Function


Sub POST_multipart_form_data(filePath As String)


Dim oFields As Object, ado As Object
Dim sBoundary As String, sPayLoad As String, GUID As String
Dim fileType As String, fileExtn As String, fileName As String
Dim sName As Variant

fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))
fileExtn = Right(filePath, Len(fileName) - InStrRev(fileName, "."))

Select Case fileExtn
 Case "png"
    fileType = "image/png"
 Case "jpg"
    fileType = "image/jpeg"
 Case "txt"
    fileType = "text/plain"
End Select

Set oFields = CreateObject("Scripting.Dictionary")
With oFields
    .Add "qquuid", GetGUID
    .Add "qqtotalfilesize", GetFileSize(filePath)
End With

sBoundary = String(27, "-") & "7e234f1f1d0654"
sPayLoad = ""
For Each sName In oFields
    sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
    sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""" & sName & """" & vbCrLf & vbCrLf
    sPayLoad = sPayLoad & oFields(sName) & vbCrLf
Next

sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""file""; " & "filename=""" & fileName & """" & vbCrLf
sPayLoad = sPayLoad & "Content-Type: " & fileType & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf



 sPayLoad = sPayLoad & "--" & sBoundary & "--"


  Set ado = CreateObject("ADODB.Stream")
  ado.Type = 1
  ado.Open
  ado.Write toArray(sPayLoad)
  ado.Write ReadBinary(filePath)
  ado.Position = 0

With CreateObject("MSXML2.ServerXMLHTTP")
    .Open "POST", "https://file.io", False
    .SetRequestHeader "Content-Type", "multipart/form-data; boundary=" & sBoundary
    .Send (ado.Read())
    'MsgBox .responseText
    Debug.Print .responseText
End With

End Sub

 

[John_w]

The terminating boundary string is in the wrong place. It should come after the file bytes.

Delete this line:

 sPayLoad = sPayLoad & "--" & sBoundary & "--"

Insert this line after ado.Write ReadBinary(filePath):

    ado.Write toArray(vbCrLf & "--" & sBoundary & "--")

Also, I'm not sure if you need the qquuid and qqtotalfilesize fields.

 

[paun_shotts]

The terminating boundary string is in the wrong place. It should come after the file bytes.

Delete this line:

 sPayLoad = sPayLoad & "--" & sBoundary & "--"

Insert this line after ado.Write ReadBinary(filePath):

    ado.Write toArray(vbCrLf & "--" & sBoundary & "--")

Also, I'm not sure if you need the qquuid and qqtotalfilesize fields.

Hi @John_w
Thanks for your reply. I have made the changes suggested, and it has now worked for .TXT file, when I download the txt file it still has text inside the file. However.. when I upload a JPG or PNG and then download it again, the file is still not able to be read. Ive tried opening it in paint, photo viewer, google chrome, and nothing works.

Any more suggestions please?

 

[John_w]

I've made a few tweaks to the form data (payload) and you also need to include the URL-encoded file name in the ?title= query string in the POST request.

This replaces the POST_multipart_form_data routine.

Sub POST_multipart_form_data(filePath As String)

    Dim oFields As Object, ado As Object
    Dim sBoundary As String, sPayLoad As String, GUID As String
    Dim fileType As String, fileExtn As String, fileName As String
    Dim sName As Variant
    
    fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))
    fileExtn = Right(filePath, Len(fileName) - InStrRev(fileName, "."))
    
    Select Case LCase(fileExtn)
        Case "png"
            fileType = "image/png"
        Case "jpg", "jpeg"
            fileType = "image/jpeg"
        Case "txt"
            fileType = "text/plain"
    End Select
    
'    Set oFields = CreateObject("Scripting.Dictionary")
'    With oFields
'        .Add "qquuid", GetGUID
'        .Add "qqtotalfilesize", GetFileSize(filePath)
'    End With
    
    sBoundary = String(27, "-") & "7e234f1f1d0654"
    sPayLoad = vbCrLf
    
'    For Each sName In oFields
'        sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
'        sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""" & sName & """" & vbCrLf & vbCrLf
'        sPayLoad = sPayLoad & oFields(sName) & vbCrLf
'    Next
    
    sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
    sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""file""; filename=""" & fileName & """" & vbCrLf
    sPayLoad = sPayLoad & "Content-Type: " & fileType & vbCrLf
    sPayLoad = sPayLoad & vbCrLf
       
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1
    ado.Open
    ado.Write toArray(sPayLoad)
    ado.Write ReadBinary(filePath)
    ado.Write toArray(vbCrLf & "--" & sBoundary & "--" & vbCrLf)
    ado.Position = 0
        
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", "https://file.io/?title=" & Application.WorksheetFunction.EncodeURL(fileName), False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & sBoundary
        .send (ado.Read())
        Debug.Print .Status, .statusText
        'MsgBox .responseText
        Debug.Print .responseText
        
        Dim downloadLink As String
        If .Status = 200 And InStr(1, .responseText, """success"":true") Then
            downloadLink = Split(Split(.responseText, """link"":")(1), """")(1)
            Debug.Print downloadLink
        End If

    End With

End Sub

 

[paun_shotts]

I've made a few tweaks to the form data (payload) and you also need to include the URL-encoded file name in the ?title= query string in the POST request.

This replaces the POST_multipart_form_data routine.

Sub POST_multipart_form_data(filePath As String)

    Dim oFields As Object, ado As Object
    Dim sBoundary As String, sPayLoad As String, GUID As String
    Dim fileType As String, fileExtn As String, fileName As String
    Dim sName As Variant
   
    fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))
    fileExtn = Right(filePath, Len(fileName) - InStrRev(fileName, "."))
   
    Select Case LCase(fileExtn)
        Case "png"
            fileType = "image/png"
        Case "jpg", "jpeg"
            fileType = "image/jpeg"
        Case "txt"
            fileType = "text/plain"
    End Select
   
'    Set oFields = CreateObject("Scripting.Dictionary")
'    With oFields
'        .Add "qquuid", GetGUID
'        .Add "qqtotalfilesize", GetFileSize(filePath)
'    End With
   
    sBoundary = String(27, "-") & "7e234f1f1d0654"
    sPayLoad = vbCrLf
   
'    For Each sName In oFields
'        sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
'        sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""" & sName & """" & vbCrLf & vbCrLf
'        sPayLoad = sPayLoad & oFields(sName) & vbCrLf
'    Next
   
    sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
    sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""file""; filename=""" & fileName & """" & vbCrLf
    sPayLoad = sPayLoad & "Content-Type: " & fileType & vbCrLf
    sPayLoad = sPayLoad & vbCrLf
      
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1
    ado.Open
    ado.Write toArray(sPayLoad)
    ado.Write ReadBinary(filePath)
    ado.Write toArray(vbCrLf & "--" & sBoundary & "--" & vbCrLf)
    ado.Position = 0
       
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", "https://file.io/?title=" & Application.WorksheetFunction.EncodeURL(fileName), False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & sBoundary
        .send (ado.Read())
        Debug.Print .Status, .statusText
        'MsgBox .responseText
        Debug.Print .responseText
       
        Dim downloadLink As String
        If .Status = 200 And InStr(1, .responseText, """success"":true") Then
            downloadLink = Split(Split(.responseText, """link"":")(1), """")(1)
            Debug.Print downloadLink
        End If

    End With

End Sub

Amazing! Thanks so much!

 

[paun_shotts]

I've made a few tweaks to the form data (payload) and you also need to include the URL-encoded file name in the ?title= query string in the POST request.

This replaces the POST_multipart_form_data routine.

Sub POST_multipart_form_data(filePath As String)

    Dim oFields As Object, ado As Object
    Dim sBoundary As String, sPayLoad As String, GUID As String
    Dim fileType As String, fileExtn As String, fileName As String
    Dim sName As Variant
   
    fileName = Right(filePath, Len(filePath) - InStrRev(filePath, "\"))
    fileExtn = Right(filePath, Len(fileName) - InStrRev(fileName, "."))
   
    Select Case LCase(fileExtn)
        Case "png"
            fileType = "image/png"
        Case "jpg", "jpeg"
            fileType = "image/jpeg"
        Case "txt"
            fileType = "text/plain"
    End Select
   
'    Set oFields = CreateObject("Scripting.Dictionary")
'    With oFields
'        .Add "qquuid", GetGUID
'        .Add "qqtotalfilesize", GetFileSize(filePath)
'    End With
   
    sBoundary = String(27, "-") & "7e234f1f1d0654"
    sPayLoad = vbCrLf
   
'    For Each sName In oFields
'        sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
'        sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""" & sName & """" & vbCrLf & vbCrLf
'        sPayLoad = sPayLoad & oFields(sName) & vbCrLf
'    Next
   
    sPayLoad = sPayLoad & "--" & sBoundary & vbCrLf
    sPayLoad = sPayLoad & "Content-Disposition: form-data; name=""file""; filename=""" & fileName & """" & vbCrLf
    sPayLoad = sPayLoad & "Content-Type: " & fileType & vbCrLf
    sPayLoad = sPayLoad & vbCrLf
      
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1
    ado.Open
    ado.Write toArray(sPayLoad)
    ado.Write ReadBinary(filePath)
    ado.Write toArray(vbCrLf & "--" & sBoundary & "--" & vbCrLf)
    ado.Position = 0
       
    With CreateObject("MSXML2.ServerXMLHTTP")
        .Open "POST", "https://file.io/?title=" & Application.WorksheetFunction.EncodeURL(fileName), False
        .setRequestHeader "Content-Type", "multipart/form-data; boundary=" & sBoundary
        .send (ado.Read())
        Debug.Print .Status, .statusText
        'MsgBox .responseText
        Debug.Print .responseText
       
        Dim downloadLink As String
        If .Status = 200 And InStr(1, .responseText, """success"":true") Then
            downloadLink = Split(Split(.responseText, """link"":")(1), """")(1)
            Debug.Print downloadLink
        End If

    End With

End Sub

Hi @John_w

Turns out file.io was not doing what I needed it to do. I need to use another site, one that the image can be viewed online, not downloaded.
Ive gone with Imgur, but there are many more.
Below is my code for uploading the image to Imgur, and I am getting a response from Imgur "FILE TYPE INVALID"

Here is the response from Imgur:
{"data":{"error":{"code":1003,"message":"File type invalid (2)","type":"ImgurException","exception":[]},"request":"\/3\/image","method":"POST"},"success":false,"status":400}

Sub UploadImageToImgur()
    Dim clientID As String
    Dim imageURL As String
    Dim filePath As String
    
    ' Set your client ID and image file path
    clientID = "684ea43ef31c5fa"
    filePath = "C:\Users\shaun\Documents\Sports Betting\NFL\Daily Bets\2023-11-14.jpg"
    
    ' Create the HTTP request
    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP")
    
    ' Load the image file as a byte array
    Dim fileStream As Object
    Set fileStream = CreateObject("ADODB.Stream")
    fileStream.Type = 1 ' binary
    fileStream.Open
    fileStream.LoadFromFile filePath
    Dim bytes() As Byte
    bytes = fileStream.Read
    
    ' Base64 encode the image data
    Dim base64EncodedImage As String
    base64EncodedImage = EncodeBase64(bytes)
    
    ' Set the request URL and method
    Dim url As String
    url = "https://api.imgur.com/3/image"
    http.Open "POST", url, False
    
    ' Set the request headers
    http.setRequestHeader "Authorization", "Client-ID " & clientID
    http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
    ' Prepare the form data
    Dim formData As String
    formData = "image=" & base64EncodedImage
    
    ' Send the request and get the response
    http.send formData
    Dim responseText As String
    responseText = http.responseText
    
    ' Log the response content to the immediate window
    Debug.Print responseText
    
    ' Parse the JSON response
    Dim json As Object
    Set json = JsonConverter.ParseJson(responseText)
    
    ' Extract the uploaded image URL if available
    If json("data").Exists("link") Then
        imageURL = json("data")("link")
        MsgBox "Uploaded image URL: " & imageURL
    Else
        MsgBox "Unable to retrieve the image URL from the response."
    End If
    
End Sub

Function EncodeBase64(ByRef arrData() As Byte) As String
    ' Create a character set
    Dim objXML As Object
    Set objXML = CreateObject("MSXML2.DOMDocument")
    Dim objNode As Object
    Set objNode = objXML.createElement("b64")
    
    ' Base64-encode the byte array
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.Text
    
    Set objNode = Nothing
    Set objXML = Nothing
[QUOTE]
End Function

[/QUOTE]

 

[John_w]

Below is my code for uploading the image to Imgur, and I am getting a response from Imgur "FILE TYPE INVALID"

You need to URL-encode the form data image parameter value:

    formData = "image=" & URLEncode(base64EncodedImage)

Public Function URLEncode(ByVal StringVal As String, Optional SpaceAsPlus As Boolean = False) As String
    
    Dim bytes() As Byte, b As Byte, i As Long, space As String
    
    If SpaceAsPlus Then space = "+" Else space = "%20"
    
    If Len(StringVal) > 0 Then
        Dim textStream As Object
        Set textStream = CreateObject("ADODB.Stream")
        
        With textStream 'New ADODB.Stream
            .Mode = 3 'adModeReadWrite
            .Type = 2 'adTypeText
            .Charset = "UTF-8"
            .Open
            .WriteText StringVal
            .Position = 0
            .Type = 1 'adTypeBinary
            .Position = 3 ' skip BOM
            bytes = .Read
        End With
        
        ReDim result(UBound(bytes)) As String
        
        For i = UBound(bytes) To 0 Step -1
            b = bytes(i)
            Select Case b
                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    result(i) = Chr(b)
                Case 32
                    result(i) = space
                Case 0 To 15
                    result(i) = "%0" & Hex(b)
                Case Else
                    result(i) = "%" & Hex(b)
            End Select
        Next i
        
        URLEncode = Join(result, "")
    End If
    
End Function