异步文件下载

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