Asynchronous File Downloads from Within VBA (Excel) - vba

Question

I've already tried using many different techniques with this... One that works pretty nicely but still ties up code when running is using 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've also used (Successfully) code to write vbscript from within Excel and then running with it wscript and waiting for the callback. But again this isn't totally async and still ties up some of the code.
I'd like to have the files download in an event driven class and the VBA code can do other things in a big loop with "DoEvents". When one file is done it can trigger a flag and the code can process that file while waiting for another.
This is pulling excel files off of an Intranet site. If that helps.
Since I'm sure someone will ask, I can't use anything but VBA. This is going to be used at the workplace and 90% of the computers are shared. I highly doubt they'll spring for the business expense of getting me Visual Studio either. So I have to 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 there is addressing responseText, but you can adjust that to use .responseBody. Here's a (synchronous) example:
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

Not sure if this is standard procedure or not but I didn't want to overly clutter my question so people reading it could understand it better.
But I've found an alternate solution to my question that is more in-line with what I was originally requesting. Thanks again to Tim as he set me on the right track, and his use of ADODB.Stream is a vital part of my solution.
This uses the Microsoft WinHTTP Services 5.1 .DLL that should be included with windows in one version or another, if not it is easily downloaded.
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'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
The main difference between this and what Tim was describing is that WINHTTPRequest has it's own built in events which I can wrap up in one neat little class and reuse wherever. It's to me, a more elegant solution than calling the XMLHttp and then passing it to a class to wait for it.
Having it wrapped up in a class like this means I can do something along the lines of 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 through URL() with URL(1,N) is the URL and URL(2,N) is the save location.
I admit that can probably be streamlined a bit but it gets the job done for me for now. Just tossing my solution out there for anyone interested.

Answer 3

#TheFuzzyGiggler: +1: Thanks for sharing back.
I know its an old post but perhaps I make someone happy with this addidion 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 could access the HTTP object from the HTTPCallBack and do many beautiful things here; the main thing is: its perfectly asynchronous now and easy to use. Hope this helps someone as the OP helped me.
I developed this further into a class: check my blog