異步文件下載

Question

我已經使用許多不同的技術與這個......一個是運行使用API​​調用時非常漂亮的作品，但依然要佔用碼已經嘗試過：

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 

和

IF URLDownloadToFile(0, "URL", "FilePath", 0, 0) Then 
End If 

我也用（成功）的代碼在Excel中編寫VBScript，然後用它運行WScript的，等待回調。但是，這不完全是異步的，並且仍然會關聯一些代碼。

我想要在事件驅動類中下載文件，並且VBA代碼可以在「DoEvents」的大循環中執行其他操作。當一個文件完成時，它可以觸發一個標誌，代碼可以在等待另一個文件的同時處理該文件。

這是將excel文件從Intranet網站中拉出來。如果有幫助。

既然我確定有人會問，我不能使用任何東西，但VBA。這將在工作場所使用，並且90％的計算機被共享。我非常懷疑他們會因爲讓我獲得Visual Studio的商業開支而跳槽。所以我必須與我所擁有的一起工作。

任何幫助將不勝感激。

Answer 1

你可以做到這一點使用XMLHTTP在異步模式和一個類來處理它的事件：

http://www.dailydoseofexcel.com/archives/2006/10/09/async-xmlhttp-calls/

的代碼有解決responseText的，但你可以調整使用.responseBody。這裏有一個（同步）例如：

Sub FetchFile(sURL As String, sPath) 
Dim oXHTTP As Object 
Dim oStream As Object 


    Set oXHTTP = CreateObject("MSXML2.XMLHTTP") 
    Set oStream = CreateObject("ADODB.Stream") 
    Application.StatusBar = "Fetching " & sURL & " as " & sPath 
    oXHTTP.Open "GET", sURL, False 
    oXHTTP.send 
    With oStream 
     .Type = 1 'adTypeBinary 
     .Open 
     .Write oXHTTP.responseBody 
     .SaveToFile sPath, 2 'adSaveCreateOverWrite 
     .Close 
    End With 
    Set oXHTTP = Nothing 
    Set oStream = Nothing 
    Application.StatusBar = False 


End Sub 

Answer 2

不知道這是標準程序或沒有，但我不想過於雜亂，我的問題使人們閱讀它可以更好地理解它。

但我發現了一個替代解決方案，我的問題更符合我最初的要求。再次感謝Tim，他讓我走上了正確的軌道，他使用ADODB.Stream是我解決方案的重要組成部分。

這使用Microsoft WinHTTP Services 5.1 .DLL，它應該包含在Windows的一個版本或另一個版本中，如果不是它很容易下載。

我用下面的代碼在一個叫「的HTTPRequest」類

Option Explicit 

Private WithEvents HTTP As WinHttpRequest 
Private ADStream As ADODB.Stream 
Private HTTPRequest As Boolean 
Private I As Double 
Private SaveP As String 

Sub Main(ByVal URL As String) 
HTTP.Open "GET", URL, True 
HTTP.send 
End Sub 

Private Sub Class_Initialize() 
Set HTTP = New WinHttpRequest 
Set ADStream = New ADODB.Stream 
End Sub 

Private Sub HTTP_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String) 
Debug.Print ErrorNumber 
Debug.Print ErrorDescription 
End Sub 


Private Sub HTTP_OnResponseFinished() 
    'Tim's code Starts' 
    With ADStream 
     .Type = 1 
     .Open 
     .Write HTTP.responseBody 
     .SaveToFile SaveP, 2 
     .Close 
    End With 
    'Tim's code Ends' 

HTTPRequest = True 
End Sub 

Private Sub HTTP_OnResponseStart(ByVal Status As Long, ByVal ContentType As String) 
End Sub 

Private Sub Class_Terminate() 
Set HTTP = Nothing 
Set ADStream = Nothing 
End Sub 

Property Get RequestDone() As Boolean 
RequestDone = HTTPRequest 
End Property 

Property Let SavePath(ByVal SavePath As String) 
SaveP = SavePath 
End Property 

這和什麼蒂姆描述之間的主要區別是，WINHTTPRequest有它自己的內置的事件，我可以在一個整潔的包裹小班和重用在任何地方。對我來說，這是一個比調用XMLHttp更加優雅的解決方案，然後將它傳遞給一個類來等待它。

有它的一類包裹起來一樣，這意味着我可以做沿着這個線的東西..

Dim HTTP(10) As HTTPRequest 
Dim URL(2, 10) As String 
Dim I As Integer, J As Integer, Z As Integer, X As Integer 

    While Not J > I 
     For X = 1 To I 
      If Not TypeName(HTTP(X)) = "HTTPRequest" And Not URL(2, X) = Empty Then 
       Set HTTP(X) = New HTTPRequest 
       HTTP(X).SavePath = URL(2, X) 
       HTTP(X).Main (URL(1, X)) 
       Z = Z + 1 
      ElseIf TypeName(HTTP(X)) = "HTTPRequest" Then 
       If Not HTTP(X).RequestDone Then 
        Exit For 
       Else 
        J = J + 1 
        Set HTTP(X) = Nothing 
       End If 
      End If 
     Next 
     DoEvents 
    Wend 

在哪裏我只是通過網址（）的URL迭代（1，N）是URL和URL（2，N）是保存位置。

我承認可以簡化一下，但現在我可以完成這項工作。只要把我的解決方案拋給那些感興趣的人。

Answer 3

@TheFuzzyGiggler：+1：謝謝你分享回來。 我知道它的一個老的文章，但也許​​我使別人高興這個addidion到TheFuzzyGigglers代碼（僅適用於類）：

我添加了兩個屬性：

Private pCallBack as string 
Private pCallingObject as object 

Property Let Callback(ByVal CB_Function As String) 
pCallBack = CB_Function 
End Property 

Property Let CallingObject(set_me As Object) 
Set pCallbackObj = set_me 
End Property 

'and at the end of HTTP_OnResponseFinished() 

CallByName pCallbackObj, pCallback, VbMethod 

在我的課堂我有

Private EntryCollection As New Collection 

Private Sub Download(ByVal fromURL As String, ByVal toPath As String) 
Dim HTTPx As HTTPRequest 
Dim i As Integer 
    Set HTTPx = New HTTPRequest 
    HTTPx.SavePath = toPath 
    HTTPx.Callback = "HTTPCallBack" 
    HTTPx.CallingObject = Me 
    HTTPx.Main fromURL 
    pHTTPRequestCollection.Add HTTPx 
End Sub 

Sub HTTPCallBack() 
Dim HTTPx As HTTPRequest 
Dim i As Integer 
For i = pHTTPRequestCollection.Count To 1 Step -1 
    If pHTTPRequestCollection.Item(i).RequestDone Then pHTTPRequestCollection.Remove i 
Next 
End Sub 

你可以從HTTPCallBack訪問HTTP對象，並在這裏做很多美麗的事情;最主要的是：它完美的異步現在和易於使用。希望這可以幫助某人，因爲OP幫助了我。

我將其進一步發展爲一個類：檢查my blog