使用 VBA 从 Excel 工作表下载 Google 云端硬盘文件

Question

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

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

Answer 1

Google 云端硬盘上的 URLDownloadToFile

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

编码

Option Explicit

' !!!VBA7-declaration might be incorrect!!!
#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