In Promises in VBA I introduced how to use promises in VBA to orchestrate asynchronous activities. One of the things that you can do in VBA asynchronously is to get data from a workbook or a database using ADO. It’s very complex to orchestrate and especially so asynchronously. I also found some issues about the connection slipping out of memory in Excel 2010, so this is very much alpha.
I provide an example promise enabled class in the downloadable promises.xlsm workbook that will handle all that. Here’s how to load data asynchronously from a workbook into a sheet in the current one.
' we'll do an async ado copy from one sheet to another With loadUsingADO(register, "sourcedata", "scratch") .done callbacks, "copyFromRecordset" .fail callbacks, "show" ' get the memory back from the ADO opeation .done callbacks, "tearDownADO" End With
This will call a function loadUsingADO (that we’ll look at in a moment) which returns a promise that it will load data as requested, and immediately gives back control to the caller. Later on, when its done, it will use callbacks.copyFromRecordset (we’ll look at that later too) to copy the retrieved data to a worksheet, and then it will try to clean up any memory consumed by ADO using callbacks.tearDownADO. Finally, if it all fails, it will use callback.show() to deal with and report on the error.
loadUsingADO function
Private Function loadUsingADO(register As cDeferredRegister, _
sheetFrom As String, sheetTo As String, _
Optional source As String = vbNullString) As cPromise
' we are going to kick off an async sql query and return a promise to it
Dim cstring As String, sql As String
Dim ad As cAdoDeferred
Set ad = New cAdoDeferred
register.register ad
' just take it from this workbook
If source = vbNullString Then source = ThisWorkbook.Path & "\" & ThisWorkbook.Name
sql = "select * from [" & sheetFrom & "$]"
' connection string for excel 2007
cstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
& source & ";Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
Set loadUsingADO = ad.execute(cstring, sql, Array(Range("'" & sheetTo & "'!a1")))
End Function
- registers itself to avoid it slipping out of memory during the asynch operation.
- sets up the connection string – in this case to an Excel workbook
- calls ad.execute() with the connection string, the sql to execute and an additional argument to be returned eventually to the .done() method of the promise() it returns.
- returns the promise back to the caller, who will use it to attach .done() and .fail() actions to.
cAdoDefferred class
Option Explicit
Private prDeferred As cDeferred
Private prOptionalArgument As Variant
Private prSql As String
Private WithEvents prConnection As ADODB.connection
Private WithEvents prRecordset As ADODB.Recordset
Public Property Get deferred() As cDeferred
Set deferred = prDeferred
End Property
Public Property Get optionalArgument() As Variant
optionalArgument = prOptionalArgument
End Property
Public Function execute(cstring As String, sql As String, _
Optional a As Variant) As cPromise
' this is an optional argument that can be passed to the resolution callback
' recommend that this is wrapped in an array to avoid set/not set problems
prOptionalArgument = a
prSql = sql
Debug.Print "im opening a connection"
' set up connection attributes and open asynchronously
With prConnection
.CommandTimeout = 60
.ConnectionTimeout = 30
.ConnectionString = cstring
.CursorLocation = adUseClient
.Mode = adModeRead
.Open , , , adAsyncConnect
End With
' this will get resolved in the async part
Set execute = prDeferred.promise
End Function
Private Sub Class_Initialize()
Set prDeferred = New cDeferred
Set prConnection = New ADODB.connection
End Sub
Private Sub prConnection_ConnectComplete(ByVal pError As ADODB.Error, _
adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.connection)
' fired when asynch connection has been made - now to get the data
Debug.Print "connection complete"
If adStatus = adStatusOK Then
With pConnection
.execute prSql, , adCmdText Or adAsyncExecute
End With
Else
' failed to connect - mark promise as rejected
prDeferred.reject (Array(pError, "failed"))
End If
End Sub
Private Sub prConnection_ExecuteComplete(ByVal RecordsAffected As Long, _
ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, _
ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, _
ByVal pConnection As ADODB.connection)
' fired when sql has been executed
Debug.Print "connection Execute complete"
If adStatus = adStatusOK Then
prDeferred.resolve (Array(pRecordset, pConnection, optionalArgument))
Else
' failed to connect - mark promise as rejected
prDeferred.reject (Array(pError, "failed"))
End If
End Sub
- The connection will fire the event ConnectComplete when done
.Open , , , adAsyncConnect
- When ConnectComplete gets fired, assuming everything is good, it will kick off a second async process,
.execute prSql, , adCmdText Or adAsyncExecute
- When that’s done it will fire ExecuteComplete. That’s where we signal that the whole thing worked or not, and also pass the result (via the deferred.promise()) object.
If adStatus = adStatusOK Then
prDeferred.resolve (Array(pRecordset, pConnection, optionalArgument))
Else
' failed to connect - mark promise as rejected
prDeferred.reject (Array(pError, "failed"))
End If
Executing .done()
.done callbacks, "copyFromRecordset"
Dim callbacks As yourCallbacks
Set callbacks = New yourCallbacks
Public Sub copyFromRecordset(a As Variant)
' arguments wrapped in array
Dim data As ADODB.Recordset, r As Range, i As Long, ws As Worksheet
Dim lb As Long
' establish where arrays start
lb = LBound(a)
' get what was passed as part for the resolution
Set data = a(lb + 0)
' this was passed as an optional argument
Set r = a(lb + 2)(lb)
Set ws = r.Worksheet
' populate the range
ws.Cells.ClearContents
' headers
For i = 0 To data.Fields.Count - 1
ws.Cells(1, i + 1).Value = data.Fields(i).Name
Next
' copy data
ws.Range("A2").copyFromRecordset data
Debug.Print ("i've done the async ado")
End Sub
Dealing with arguments from deferred.resolve()
prDeferred.resolve (Array(pRecordset, pConnection, optionalArgument))
Dim data As ADODB.Recordset
Dim lb As Long, r as Range
' establish where arrays start
lb = LBound(a)
' get what was passed as part for the resolution
Set data = a(lb + 0)
' this was passed as an optional argument
Set r = a(lb + 2)(lb)
.done callbacks, "tearDownADO"
Public Sub tearDownADO(a As Variant)
' clean up after an ADO
' arguments wrapped in array will be
Dim data As ADODB.Recordset, connection As ADODB.connection
Dim lb As Long
' establish where arrays start
lb = LBound(a)
' get what was passed as part for the resolution
Set data = a(lb + 0)
Set connection = a(lb + 1)
' close the record set & connection
data.Close
connection.Close
Debug.Print "ive closed the recordset"
End Sub