Question

我正在尝试编写代码，以便通过Excel vba自动从网站下载文件。我知道有很多关于这个话题的帖子，但到目前为止没有运气。前几行代码是这样的：

Sub testing()

Dim ie as object

Url _base = "http://www..../download.aspx?id="
Num = cells(1,1).value
Set ie = createobject ("internetexplorer.application")
Ie.visible = true

For i = 1 to num
   Url = url _base & i
    ....

然后我变得无能为力。问题是winhttp似乎只下载csv文件，而urldownloadtofile需要一个以文件扩展名结尾的实体url路径。但是，我的情况是链接重定向到实际文件位置（没有显示扩展名），文件也可以是任何扩展名，如pdf，jpg和doc。

提前全部谢谢！

Answer 1

好的，编辑答案折叠反馈，三种不同的方式发出HTTP请求，似乎你想要捕获重定向，状态代码是300-303,307-308。试试这个并提供关于是否重定向的反馈。

Option Explicit

Private Sub TestGetFileFromWeb()
     Call SaveTextToFile(GetFileFromWeb2("http://www.wikipedia.com"), "c:\temp\wikipedia2.txt")
     Call SaveTextToFile(GetFileFromWeb3("http://www.wikipedia.com"), "c:\temp\wikipedia3.txt")

     '* placed last because it gives "Access Denied" Run-time error '-2147024891   &h80070005
     'Call SaveTextToFile(GetFileFromWeb1("http://www.wikipedia.com"), "c:\temp\wikipedia1.txt")
     Call SaveTextToFile(GetFileFromWeb1("http://www.bbc.com"), "c:\temp\bbc.txt")

End Sub

Private Function SaveTextToFile(ByRef sText As String, ByVal sFileName As String) As Boolean


    '* Requires Tools ->References -> Microsoft Scripting Runtime

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject

    Dim txtOut As Scripting.TextStream
    Set txtOut = fso.CreateTextFile(sFileName, , True)
    txtOut.Write sText
    txtOut.Close
    Set txtOut = Nothing
    Set fso = Nothing

    SaveTextToFile = True

End Function

Private Function GetFileFromWeb1(ByVal sURL As String) As String

    '* Requires Tools->References->Microsoft Xml, v.6.0

    Dim xHTTPRequest As MSXML2.XMLHTTP60
    Set xHTTPRequest = New MSXML2.XMLHTTP60

    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.Send
    Debug.Assert WasRedirected(xHTTPRequest.Status)

    GetFileFromWeb1 = xHTTPRequest.ResponseText

End Function


Private Function GetFileFromWeb2(ByVal sURL As String) As String

    '* Requires Tools->References->Microsoft WinHTTP Services, version 5.1

    Dim oWinHttp As WinHttp.WinHttpRequest
    Set oWinHttp = New WinHttp.WinHttpRequest

    oWinHttp.Open "GET", sURL, False
    oWinHttp.Send
    Debug.Assert WasRedirected(oWinHttp.Status)
    GetFileFromWeb2 = oWinHttp.ResponseText

End Function


Private Function WasRedirected(ByVal lStatus As Long) As Boolean

    'http://qnimate.com/redirection-and-duplicate-content-in-websites/
    'There are many types of HTTP redirection.
    '
    '300 Redirect or Multiple Choices
    '301 Redirect or permanent redirect
    '302 Redirect or Found or Temporary Redirect
    '303 Redirect or See Other
    '307 Redirect or Temporary Redirect
    '308 Redirect or Permanent Redirect
    'HTTP refresh header

    WasRedirected = (lStatus = 300 Or lStatus = 301 Or lStatus = 302 Or lStatus = 303 Or lStatus = 307 Or lStatus = 308)

End Function


Private Function GetFileFromWeb3(ByVal sURL As String) As String

    '* Requires Tools->References->Microsoft Xml, v.6.0

    Dim xHTTPRequest As MSXML2.ServerXMLHTTP60
    Set xHTTPRequest = New MSXML2.ServerXMLHTTP60
    xHTTPRequest.Open "GET", sURL, False
    xHTTPRequest.Send
    Debug.Assert WasRedirected(xHTTPRequest.Status)
    GetFileFromWeb3 = xHTTPRequest.ResponseText

End Function

带有随机文件扩展名的Excel vba下载文件

1 个答案: