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

但是，每次运行代码时，它只会创建一个空的zip文件而不是下载文件。

任何帮助？

Answer 1

我假设您可以使用网络浏览器并登录

来获取文件

底部附近的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

使用VBA从URL下载zip文件

1 个答案: