使用 VBA 从 Excel Sheet 下载 Google 驱动器文件

Question

下面的 hyperlink 出现在 Excel Sheet 的一个单元格中。如果单击它会打开并显示一个文件（授予具有 link 的任何人的权限）

如何使用 Excel vba 将 linked 文件下载到本地文件夹？

Answer 1

Google 驱动器

上的 URLDownloadToFile

文件夹 C:\Test 必须存在，此示例才能运行。
有关 URLDownloadToFile 的更多信息，请尝试搜索 SO 或 Google。

代码

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownLoadToFileA" (ByVal pCaller As Long, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Function downloadFile( _
    ByVal FileURL As String, _
    ByVal FilePath As String) _
As Boolean
    Const ProcName As String = "downloadFile"
    On Error GoTo clearError
    
    URLDownloadToFile 0, FileURL, FilePath, 0, 0
    downloadFile = True

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Sub downloadGoogleDrive()
    
    Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
    Const UrlRight As String = "&export=download"
    
    Const FileID As String = "17bw2KgzD1ifcA7rdXdxiN9bN70g8jnMO"
    Const FilePath As String _
        = "C:\Test\Type1 and Type 2 errors - Atyati Temp.jpg"
    
    Dim Url As String: Url = UrlLeft & FileID & UrlRight
    
    Dim wasDownloaded As Boolean
    wasDownloaded = downloadFile(Url, FilePath)
    If wasDownloaded Then
        MsgBox "Success"
    Else
        MsgBox "Fail"
    End If

End Sub

Answer 2

使用原始文件名从 Google 驱动器下载文件

Sub DownloadGoogleDriveWithFilename()
Dim myOriginalURL As String
Dim myURL As String
Dim FileID As String
Dim xmlhttp As Object
Dim FolderPath As String
Dim FilePath As String
Dim name0 As Variant
Dim oStream As Object
Dim wasDownloaded As Boolean
Application.ScreenUpdating = False
    ''URL from share link or Google sheet URL or Google doc URL
    myOriginalURL = "https://drive.google.com/file/d/1MnaC9-adPeEjkv7AEARchoYLLSWELBsy/view?usp=sharing"
    FileID = Split(myOriginalURL, "/d/")(1) ''split after "/d/"
    FileID = Split(FileID, "/")(0)  ''split before "/"
Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
Const UrlRight As String = "&export=download"
    myURL = UrlLeft & FileID & UrlRight
Debug.Print myURL
        Set xmlhttp = CreateObject("winhttp.winhttprequest.5.1")
        xmlhttp.Open "GET", myURL, False  ', "username", "password"
        xmlhttp.Send

        name0 = xmlhttp.getResponseHeader("Content-Disposition")
        If name0 = "" Then
            MsgBox "file name not found"
            Exit Sub
        End If
        
        Debug.Print name0
        name0 = Split(name0, "=""")(1) ''split after "=""
        name0 = Split(name0, """;")(0)  ''split before "";"
'        name0 = Replace(name0, """", "") ' Remove double quotes
        Debug.Print name0

        FolderPath = ThisWorkbook.path
        FilePath = FolderPath & "\" & name0
      
 ''This part is equvualent to URLDownloadToFile(0, myURL, FolderPath & "\" & name0, 0, 0)
 ''just without having to write Windows API code for 32 bit and 64 bit.
    If xmlhttp.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write xmlhttp.responseBody
        oStream.SaveToFile FilePath, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If
    
 Application.ScreenUpdating = True
 
  If FileExists(FilePath) Then
        wasDownloaded = True
        ''open folder path location to look at the downloded file
        Call Shell("explorer.exe" & " " & FolderPath, vbNormalFocus)
  Else
        wasDownloaded = False
        MsgBox "failed"
  End If
End Sub

Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function

使用 VBA 从 Excel Sheet 下载 Google 驱动器文件

Download Google Drive File from Excel Sheet using VBA

excel

vba

flysystem-google-drive

Google 驱动器