Search code examples
excelvbagoogle-drive-api

How to pass metadata to Google Drive API upload with VBA

I am trying to upload a local file to the google drive using vba and Google Drive Api. I am able to upload the file successfully and able to preview on the drive.

Only issue I have is , I don't know how/where to pass the filename. All my files saved as untitled by default.

Here is my code:

Sub GoogleDriveAPI()

Set req = New MSXML2.ServerXMLHTTP60
Dim content As Byte
Dim fPath As String
Dim Filename As String
    
fPath = Range("C5").Value

'Filename = "merged.pdf"

'arg = "{""name"": Filename}"

req.Open "POST", "https://www.googleapis.com/upload/drive/v3/files?uploadType=media", False
req.setRequestHeader "Authorization", "Bearer access-token"
req.setRequestHeader "Content-Type", "application/application/octet-stream"
req.setRequestHeader "Content-length", FileLen(fPath)
req.Send ReadByteArrFromFile(fPath)

If req.Status = 200 Then '200 = OK
    Debug.Print req.responseText
    MsgBox ("Upload completed successfully")
Else
    MsgBox req.Status & ": " & req.StatusText
    Debug.Print req.responseText
End If


End Sub

Result:

enter image description here

I checked this doc from Google but couldn't figure it out. Any help would be appriciated!

Solution

  • Construct a multipart upload

    Option Explicit

Sub GoogleDriveAPI()

    Const reqURL = "https://www.googleapis.com/upload/drive/v3/files?uploadType=multipart"
    Const TOKEN = "api-token"
    
    Dim content() As Byte, fPath As String, Filename As String
    Dim file_metadata As String
    
    fpath = "C:\path-to-file\" ' folder
    Filename = "merged.pdf"
    file_metadata = "{'name':'" & Filename & "'}"
        
    ' generate boundary
    Dim BOUNDARY, s As String, n As Integer
    For n = 1 To 16: s = s & Chr(65 + Int(Rnd * 25)): Next
    BOUNDARY = s & CDbl(Now)

    Dim part As String, ado As Object
   
    part = part & "--" & BOUNDARY & vbCrLf
    part = part & "Content-Type: application/json; charset=UTF-8" & vbCrLf
    part = part & "MIME-Version: 1.0" & vbCrLf & vbCrLf
    part = part & file_metadata & vbCrLf
    
    ' content
    part = part & "--" & BOUNDARY & vbCrLf
    part = part & "Content-Type: application/pdf" & vbCrLf
    part = part & "MIME-Version: 1.0" & vbCrLf
    part = part & "Content-Transfer-Encoding: binary" & vbCrLf & vbCrLf
    
    ' read  file as binary
    Set ado = CreateObject("ADODB.Stream")
    ado.Type = 1 'binary
    ado.Open
    ado.LoadFromFile fPath & Filename
    ado.Position = 0
    content = ado.read
    ado.Close

    ' combine part, csv , end
    ado.Open
    ado.Position = 0
    ado.Type = 1 ' binary
    ado.Write ToBytes(part)
    ado.Write content
    ado.Write ToBytes(vbCrLf & "--" & BOUNDARY & "--")
    ado.Position = 0

    Dim req As New MSXML2.XMLHTTP60
    With req
        .Open "POST", reqURL, False
        .setRequestHeader "Accept", "Application/json"
        .setRequestHeader "Authorization", "Bearer " & TOKEN
        .setRequestHeader "Content-Type", "multipart/related; boundary=" & BOUNDARY
        .send ado.read
    End With
    
    If req.Status = 200 Then '200 = OK
        Debug.Print req.responseText
        MsgBox ("Upload completed successfully")
    Else
        MsgBox req.Status & ": " & req.statusText
        Debug.Print req.responseText
    End If

End Sub

Function ToBytes(str As String) As Variant

    Dim ado As Object
    Set ado = CreateObject("ADODB.Stream")
    ado.Open
    ado.Type = 2 ' text
    ado.Charset = "_autodetect"
    ado.WriteText str
    ado.Position = 0
    ado.Type = 1
    ToBytes = ado.read
    ado.Close

End Function