如何使用 VBA（没有 Internet Explorer）下载文件

Question

我需要在 Excel 中使用 VBA 从网站下载 CSV 文件。服务器还需要对我进行身份验证，因为它是来自调查服务的数据。

为此，我找到了很多使用 VBA 控制的 Internet Explorer 的示例。然而，它大多是缓慢的解决方案，而且大多数也是令人费解的。

更新： 过了一会儿，我发现了一个在 Excel 中使用 Microsoft.XMLHTTP 对象的绝妙解决方案。我想分享下面的解决方案以供将来参考。

Answer 1

此解决方案基于此网站： http://social.msdn.microsoft.com/Forums/en-US/bd0ee306-7bb5-4ce4-8341-edd9475f84ad/excel-2007-use-vba-to-download-save-csv-from-url

稍作修改以覆盖现有文件并传递登录凭据。

Sub DownloadFile()

Dim myURL As String
myURL = "https://YourWebSite.com/?your_query_parameters"

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile "C:\file.csv", 2 ' 1 = no overwrite, 2 = overwrite
    oStream.Close
End If

End Sub

Answer 2

Declare PtrSafe 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

Sub Example()
    DownloadFile$ = "someFile.ext" 'here the name with extension
    URL$ = "http://some.web.address/" & DownloadFile 'Here is the web address
    LocalFilename$ = "C:\Some\Path" & DownloadFile !OR! CurrentProject.Path & "\" & DownloadFile 'here the drive and download directory
    MsgBox "Download Status : " & URLDownloadToFile(0, URL, LocalFilename, 0, 0) = 0
End Sub

Source

我在使用 URL 中的用户名和地址寻找从 FTP 下载时发现了上述内容。用户提供信息，然后拨打电话。

这很有帮助，因为我们的组织有 Kaspersky AV，它阻止 active FTP.exe，但不阻止 Web 连接。我们无法使用 ftp.exe 进行内部开发，这是我们的解决方案。希望这有助于其他寻找信息的人！

Answer 3

上面的修改版本，使其更具动态性。

Public Function DownloadFileB(ByVal URL As String, ByVal DownloadPath As String, ByRef Username As String, ByRef Password, Optional Overwrite As Boolean = True) As Boolean
    On Error GoTo Failed

    Dim WinHttpReq          As Object: Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")

    WinHttpReq.Open "GET", URL, False, Username, Password
    WinHttpReq.send

    If WinHttpReq.Status = 200 Then
        Dim oStream         As Object: Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile DownloadPath, Abs(CInt(Overwrite)) + 1
        oStream.Close
        DownloadFileB = Len(Dir(DownloadPath)) > 0
        Exit Function
    End If

Failed:
    DownloadFileB = False
End Function

Answer 4

上述解决方案的修改版本，使其更具动态性。

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

Public Function DownloadFileA(ByVal URL As String, ByVal DownloadPath As String) As Boolean
    On Error GoTo Failed
    DownloadFileA = False
    'As directory must exist, this is a check
    If CreateObject("Scripting.FileSystemObject").FolderExists(CreateObject("Scripting.FileSystemObject").GetParentFolderName(DownloadPath)) = False Then Exit Function
    Dim returnValue As Long
    returnValue = URLDownloadToFile(0, URL, DownloadPath, 0, 0)
    'If return value is 0 and the file exist, then it is considered as downloaded correctly
    DownloadFileA = (returnValue = 0) And (Len(Dir(DownloadPath)) > 0)
    Exit Function

Failed:
End Function

Answer 5

我为此苦苦挣扎了几个小时，直到我发现它可以在一行 powershell 中完成：

invoke-webrequest -Uri "http://myserver/Reports/Pages/ReportViewer.aspx?%2fClients%2ftest&rs:Format=PDF&rs:ClearSession=true&CaseCode=12345678" -OutFile "C:\Temp\test.pdf" -UseDefaultCredentials

我曾考虑纯粹在 VBA 中执行此操作，但它会运行到多个页面，因此每次我想下载文件时，我只需从 VBA 调用我的 powershell 脚本。

简单。

Answer 6

Public Sub Test_DownloadFile()
 Dim URLStr As String, DLPath As String, UName As String, PWD As String, DontOverWrite As Boolean
 URLStr = "http.."
 DLPath = Environ("USERPROFILE") & "\Downloads\TEST.PDF"
 UName = ""
 PWD = ""
 DontOverWrite = False
 Call DownloadFile(URLStr, DLPath, UName, PWD, DontOverWrite)
End Sub

---

Public Sub DownloadFile(ByVal URLStr As String, ByVal DLPath As String, Optional ByVal UName As String, Optional ByVal PWD As String, Optional DontOverWrite As Boolean)
 On Error GoTo Failed

 Dim WinHttpReq As Object
 Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
 WinHttpReq.Open "GET", URLStr, False, UName, PWD
 WinHttpReq.send

If WinHttpReq.status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    Dim OWrite As Integer
    If DontOverWrite = True Then
     OWrite = 1
    Else
     OWrite = 2
    End If
    oStream.SaveToFile DLPath, OWrite
    oStream.Close
    Debug.Print "Downloaded " & URLStr & " To " & DLPath
    Exit Sub
End If
Failed:
 Debug.Print "Failed to DL " & URLStr
End Sub