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