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

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