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