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

How do I download a file using VBA (without Internet Explorer)

提问by Ole Henrik Skogstr?m

I need to download a CSV file from a website using VBA in Excel. The server also needed to authenticate me since it was data from a survey service.

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

I found a lot of examples using Internet Explorer controlled with VBA for this. However, it was mostly slow solutions and most were also convoluted.

为此，我发现了很多使用由 VBA 控制的 Internet Explorer 的示例。然而，它大多是缓慢的解决方案，而且大多数也很复​​杂。

Update:After a while I found a nifty solution using Microsoft.XMLHTTP object in Excel. I thought to share the solution below for future reference.

更新：一段时间后，我在 Excel 中使用 Microsoft.XMLHTTP 对象找到了一个很好的解决方案。我想分享下面的解决方案以供将来参考。

回答by Ole Henrik Skogstr?m

This solution is based from this website: http://social.msdn.microsoft.com/Forums/en-US/bd0ee306-7bb5-4ce4-8341-edd9475f84ad/excel-2007-use-vba-to-download-save-csv-from-url

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

It is slightly modified to overwrite existing file and to pass along login credentials.

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

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

回答by Cole Busby

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

来源

I found the above when looking for downloading from FTP with username and address in URL. Users supply information and then make the calls.

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

This was helpful because our organization has Kaspersky AV which blocks activeFTP.exe, but not web connections. We were unable to develop in house with ftp.exe and this was our solution. Hope this helps other looking for info!

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

回答by AndrewK

A modified version of above solution to make it more dynamic.

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

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

回答by AndrewK

A modified version of above to make it more dynamic.

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

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