使用VBA從url下載zip文件

Question

我使用this link作爲從url下載zip文件的參考。

我使用的代碼是在下面

Sub DownloadZipExtractCsvAndLoad() 
    Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String 
    ' UrlFile to the ZIP archive 
    UrlFile = "https://loanperformancedata.fanniemae.com/lppub/publish?file=2008Q1.zip" 
    ' Extract ZipFile from UrlFile 
    ZipFile = "2008Q1.zip" 
    ' Define temporary folder 
    Folder = "C:\Users\xxxxxx\Desktop\" 
    ' Disable screen updating to avoid blinking 
    Application.ScreenUpdating = False 
    ' Trap errors 
    On Error GoTo exit_ 
    ' Download UrlFile to ZipFile in Folder 
    If Not Url2File(UrlFile, Folder & ZipFile, "xxx", "xxxx") Then 
    MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error" 
    Exit Sub 
    End If 
exit_: 
    ' Restore screen updating 
    Application.ScreenUpdating = True 
    ' Inform about the reason of the trapped error 
    If Err Then MsgBox Err.Description, vbCritical, "Error" 
End Sub 

Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean 
'ZVI:2017-01-07 Download UrlFile and save it to PathName. 
'    Use optional Login and Password if required. 
'    Returns True on success downloading. 
    Dim b() As Byte, FN As Integer 
    On Error GoTo exit_ 
    If Len(Dir(PathName)) Then Kill PathName 
    With CreateObject("MSXML2.XMLHTTP") 
    .Open "GET", UrlFile, False, Login, Password 
    .send 
    If .Status <> 200 Then Exit Function 
    b() = .responseBody 
    FN = FreeFile 
    Open PathName For Binary Access Write As #FN 
    Put #FN, , b() 
exit_: 
    If FN Then Close #FN 
    Url2File = .Status = 200 
    End With 
End Function 

不過，我每次運行該代碼時，它只會創建一個空的壓縮文件，而不是下載的文件。

任何幫助？

Answer 1

我假設你能夠通過使用Web瀏覽器和登錄

拿到文件時，它是B（）接近底部

它應該是：

b = fileObj.responseBody 
. 
. 
Put #FN, , b 

我測試它通過檢索UrlFile =「https://www.google.ca/」

我添加了幾行來打印狀態在文件檢索嘗試後

Sub DownloadZipExtractCsvAndLoad() 

    Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String 


    UrlFile = "https://loanperformancedata.fanniemae.com/lppub/publish?file=2008Q1.zip" ' UrlFile to the ZIP archive 
    ZipFile = "2008Q1.zip"                 ' Extract ZipFile from UrlFile 

    UrlFile = "https://www.google.ca/"     ' debug ... test url 
    ZipFile = "2008Q1.html"        ' debug ... test file 

    Folder = "C:\Users\js135001\Desktop\"             ' Define temporary folder 
    Application.ScreenUpdating = False              ' Disable screen updating to avoid blinking 

' On Error GoTo exit_err                ' Trap errors 

    If Not Url2File(UrlFile, Folder & ZipFile, "xxx", "xxxx") Then       ' Download UrlFile to ZipFile in Folder 
     MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error" 
     Exit Sub 
    End If 

exit_err: 
    Application.ScreenUpdating = True              ' Restore screen updating 

    If Err Then MsgBox Err.Description, vbCritical, "Error"        ' Inform about the reason of the trapped error 

End Sub 

Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean 
    ' ZVI:2017-01-07 Download UrlFile and save it to PathName. 
    '    Use optional Login and Password if required. 
    '    Returns True on success downloading. 

    Dim b() As Byte, FN As Integer 

' On Error GoTo exit_err 

    If Len(Dir(PathName)) Then Kill PathName 

    Dim httpObj As Object 
    Set httpObj = CreateObject("MSXML2.XMLHTTP") 

    httpObj.Open "GET", UrlFile, False, Login, Password 
    httpObj.send 

    Debug.Print httpObj.Status    ' debug 
    Debug.Print httpObj.statusText   ' debug 

    If httpObj.Status <> 200 Then Exit Function 

    b = httpObj.responseBody 
    FN = FreeFile 
    Open PathName For Binary Access Write As #FN 
    Put #FN, , b 

' Put #FN, , httpObj.responseBody ' you could do this, and not use b() at all 

exit_err: 
    If FN Then Close #FN 
    Url2File = (httpObj.Status = 200)    ' return true/false 

End Function