Verwenden Sie VBA zum Herunterladen von Zip-Datei von URL

Question

Ich verwende this link als Referenz zum Herunterladen einer ZIP-Datei von URL.

Der Code ich verwende ist in unter

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 

jedoch nur jedes Mal, wenn ich den Code ausführen, wird es eine leere Zip-Datei statt dem Herunterladen der Datei erstellen.

Irgendwelche Hilfe?

Answer 1

Ich gehe davon aus, dass Sie in der Lage sind, die Datei zu erhalten, indem Sie einen Webbrowser und die Protokollierung in

mit ihm die b() in der Nähe der unteren

es sein sollte:

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

Ich testete es durch Abrufen UrlFile = "https://www.google.ca/"

Ich habe ein paar Zeilen hinzugefügt, um den Status zu drucken nach dem Dateiabrufversuch

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