使用web api下载zip文件会导致文件损坏

时间:2018-04-30 07:49:56

标签: excel-vba vba excel

我有一个VBA代码,可以根据URL下载zip文件并将其保存到文件夹中。但是,下载的文件已损坏。使用VBA代码下载的文件的文件大小明显低于实际文件。 以下是我正在使用的代码:

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

Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias _
"DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Sub DownloadFile 
    Dim L as long
    L = URLDownloadToFile(0&, UrlFileName, DestinationFileName, 0&, 0&)

    If L = 0 Then
      Debug.Print "Download successful"
    Else
       Debug.Print "Download unsuccessful"
    End If
End Sub

` 我正在下载ZIP文件的站点需要登录,我在运行所述VBA代码之前登录到该站点。

示例网址(不是真正的网址):https://www.samplewebsite.org/bsplink14/updownload/motorqcopia2.asp?vr=&name=VBGHFaz7243%5F20180424%5F0403%5FAirline%5FZCVDRFDBilling.zip&filtroread=true&extid=INDEFD1834262&rif=3373&s3s=47c7d4b47bc1c57cc4c6c29959dca0

你能帮我解决这个问题吗?

1 个答案:

答案 0 :(得分:0)

确保引用MSXML,插入一个类模块,并在其中包含以下代码。只有在函数返回True的情况下才执行DownloadToFile,应该可以正常工作。

Public Function DoLoginByPost(URL As String, strUser As String, strPassword As String) As Boolean

    Dim xHttp As MSXML2.XMLHTTP
    Dim sTICKER As String

    sTICKER = "user=" & strUser & "&pass=" & strPassword & "&logintype=login&pid=4&login=Login" 
    'Check this and edit accordingly by e.g. using the web developer tools in your browser when logging in regularly.
    'You should be able to identify what form data is being sent when loggin on.
    Set xHttp = New MSXML2.XMLHTTP
    xHttp.Open "POST", URL
    xHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xHttp.send sTICKER

    Do Until xHttp.READYSTATE = 4
        DoEvents
    Loop

    If xHttp.Status = 200 Then
        DoLoginByPost = True
        Else:   DoLoginByPost = False
    End If

End Function



'After receiving "TRUE", alter your original code to:

Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "Get", UrlFileName, False
xHttp.send

Do Until xHttp.ReadyState = 4
  DoEvents
Loop

Open DestinationFileName For Binary As #1
   Put #1, , xHttp.responseBody
Close #1