Asynchronous file downloads from VBA (Excel)

Question

I already tried using a lot of different methods with this ... One that works pretty well, but still binds the code at startup, uses the api call:

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 

and

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

I also used (successfully) code to write vbscript from Excel and then ran wscript with it and expected a callback. But again, this is not completely asynchronous and still binds some of the code.

I want the files to be loaded into an event-driven class, and VBA code can do other things in a big loop using DoEvents. When one file is executed, it can call a flag, and code can process this file, waiting for another.

This pulls excel files from the Intranet site. If it helps.

Since I'm sure someone will ask, I cannot use anything but VBA. This will be used in the workplace, and 90% of the computers will be shared. I highly doubt that they will spring at the expense of the business for getting Visual Studio. Therefore, I must work with what I have.

Any help would be greatly appreciated.

Answer 1

You can do this using xmlhttp in asynchronous mode and a class to handle its events:

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

The code has a responseText address, but you can configure it to use .responseBody. Here is an example (synchronous):

 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

I'm not sure if this is a standard procedure or not, but I did not want to clutter up my question unnecessarily so that people reading this could better understand.

But I found an alternative solution to my question, which is more consistent with what I originally requested. Thanks again to Tim as he set me on the right track and using ADODB.Stream is an important part of my solution.

This uses Microsoft WinHTTP Services 5.1.DLL, which must be enabled on Windows in one version or another if it is not loaded.

I use the following code in a class called "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 code Starts' With ADStream .Type = 1 .Open .Write HTTP.responseBody .SaveToFile SaveP, 2 .Close End With 'Tim 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 

The main difference between this and what Tim described is that WINHTTPRequest has its own built-in events, which I can wrap in one neat little class and use it everywhere. This is a more elegant solution for me than calling XMLHttp and then passing it to the class to wait for it.

Having completed this in the classroom, this means that I can do something in accordance with this.

 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 

Where I just iterate over URL () with URL (1, N), this is URL and URL (2, N) is the save location.

I admit that it might be a little easier, but now for me it is done for me. Just drop my decision there for everyone who cares.

Answer 3

@TheFuzzyGiggler: +1: Thanks for sharing. I know his old post, but maybe I'm making someone happy with this add-on to TheFuzzyGigglers code (works only in classes):

I added two properties:

 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 

In my class I have

  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 

You can access the HTTP object from HTTPCallBack and do a lot of great things here; the main thing: now it is completely asynchronous and easy to use. Hope this helps someone since FP helped me.

I developed this further into a class: check out my blog