VBA, ADODB - Asynchronous Query Execution with ADODB.Connection Events

VBA doesn't have multiple threads but that's ok because network latent operations such as running queries are packed into libraries which do the multi-threading for you. The ADODB.Connection object that is used to connect to a database can run queries in asynchronous mode with notification of completion implemented with an event if you declare the Connection object with the WithEvents keyword and and supply adAsyncExecute to the Connection's Execute method.

What follows is a code pattern not actual code because I do not know what databases you have installed on your computer dear reader. But what must be stressed is that this is to be placed into a class module (not a standard module). I called my class AsyncQuery

Option Explicit

Private WithEvents cnAsynchronousConnection As ADODB.Connection

Public Sub RunAsyncQuery()
    
    Set cnAsynchronousConnection = New ADODB.Connection

    cnAsynchronousConnection.connectionString = "" '<---- Insert your connection string

    
    cnAsynchronousConnection.Open
    
    Debug.Print "Preparing to execute asynchronously: " & Now
    cnAsynchronousConnection.Execute "<select query>", adAsyncExecute  '<----- Insert you own query

    Debug.Print "Has begun executing asynchronously: " & Now
End Sub

Private Sub cnAsynchronousConnection_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)
    Debug.Print "The query has completed asynchronously: " & Now
End Sub

Then in a standard module place the following code.

Option Explicit

Sub Test()
    Dim oAsyncQuery As AsyncQuery
    Set oAsyncQuery = New AsyncQuery

    oAsyncQuery.RunAsyncQuery

End Sub

So without a database we can't take this any further. There are two key points working here, firstly there is the WithEvents keyword in the variable declaration which is only valid in a class module. Secondly there is the flag adAsyncExecute which must be passed to the Connection's Execute method. I have highlighted these key points in bold red.

VBA - WinHttpRequest - No asynchronous chunks

Summary: WinHttp.WinHttpRequest is yet another Http request class that has some features such as chunking, sadly it won't chunk asynchronously.

So someone asked a good question of SO about chunking data from a web service, the questioner complained about missing data. With the object browser it can be seen that WinHttp.WinHttpRequest supports events which can be used to trap chunks of data. It looked promising. However, after some experimentation it does not seem possible to have asynchronous chunking. One can have asynchronous request and receive the whole request or one can have a chunked synchronous request. One cannot have both chunked and asynchronous.

I give code below some that others can check my results. I tested against a Node.js slow and chunky web service from a prior blog post. In order to sink events it is necessary to use the WithEvents keyword in a class module. Here is the class module which I called WHRChunked

Option Explicit

'* Tools->References
'WinHttp        Microsoft WinHTTP Services, version 5.1          C:\WINDOWS\system32\winhttpcom.dll

Private WithEvents moWHR As WinHttp.WinHttpRequest

Public msBufferedResponse As String
Public mbFinished As Boolean

Private Const mbDEFAULT_DEBUG  As Boolean = True
Public mvDebug As Variant

Public Property Get bDebug() As Boolean
    If IsEmpty(mvDebug) Then mvDebug = mbDEFAULT_DEBUG
    
    bDebug = mvDebug
End Property
Public Property Let bDebug(ByVal bRHS As Boolean)
    mvDebug = bRHS
End Property

Public Sub HttpGet(ByVal sURL As String, bAsync As Boolean)
    On Error GoTo ErrHandler

    Set moWHR = New WinHttp.WinHttpRequest
    
    
    mbFinished = False
    msBufferedResponse = ""
    
    moWHR.Open Method:="GET", URL:=sURL, async:=bAsync
    
    moWHR.send
    Debug.Print "send called with bAsync=" & bAsync
SingleExit:
    Exit Sub
ErrHandler:
    Debug.Print "Error (" & Err.Number & ") " & Err.Description
    Stop
    Resume
    
End Sub


Private Sub moWHR_OnError(ByVal ErrorNumber As Long, ByVal ErrorDescription As String)
    Debug.Print "moWHR_OnError"

End Sub

Private Sub moWHR_OnResponseDataAvailable(Data() As Byte)
    
    Dim sThisChunk As String
    sThisChunk = StrConv(Data(), vbUnicode)
    
    Debug.Print "moWHR_OnResponseDataAvailable (" & Len(sThisChunk) & ")"
    
    msBufferedResponse = msBufferedResponse & sThisChunk
    
End Sub

Private Sub moWHR_OnResponseFinished()
    Debug.Print "moWHR_OnResponseFinished"
    mbFinished = True
End Sub

Private Sub moWHR_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)

    Dim v
    v = VBA.Split(moWHR.getAllResponseHeaders, vbNewLine)
    Debug.Print "moWHR_OnResponseStart"

End Sub

And we need some code in a standard module to call into the class, remember this needs the web service from previous blog post.

Option Explicit

Sub Test()
    Dim oWHRChunked As WHRChunked
    Set oWHRChunked = New WHRChunked
    
    oWHRChunked.HttpGet "http://localhost:34957/slowAndChunkyWebService?chunkCount=2", True
    'oWHRChunked.HttpGet "http://localhost:34957/slowAndChunkyWebService?chunkCount=2", False
    
    While oWHRChunked.mbFinished = False
        DoEvents
    Wend
    
    Debug.Print oWHRChunked.msBufferedResponse


End Sub

So to experiment simply swap the above commented line for the other to see the different effects, the evidence is posted to the Immediate window using Debug.Print .

Final thoughts, I'm disappointed by this finding I hope I have it wrong. I must do a comparison table of the different features between MSXML2.XMLHTTP60, MSXML2.ServerXMLHTTP60 and WinHttpRequest.

VBA - Some copy and pastable code for retrying an asynchronous operation

Some operations are asynchronous, a line of VBA code may say close window but the OS responds in its own time, the next line of code that relied upon that window being closed then runs the risk of failing if run too soon. Now, we can add delays or alternatively we can implement a retry mechanism, I chose the latter.

I'm not happy with the code but nevertheless I am depositing some code here today for future use. Initially I built a class but then decided it was over-engineered and I scrapped that and replaced it with some boilerplate code to be added when an operation needs retrying. You can see the code below, note how there is one single line of code surround by fluff to make the retry mechanism work.

I'm really not happy but can't help feeling that an OS level mechanism would be helpful or a future language implementation ships a new feature.

The code is meant to sit in a class and uses two class level variables, bVerbose and bDebug. I recommend copying, pasting then customising. I do not recommend trying to write a utility class to handle many use cases.

Anyway here is the code.

Public bVerbose As Boolean
Public bDebug As Boolean

Function CreateFolderMultipleAttempts(ByVal sFolder As String)
    
    On Error GoTo ErrHandler
    
    Dim dtInterval As Date
    dtInterval = Interval(1)
    
    Const lMaxAttempts As Long = 3

    Dim lAttempts As Long
    lAttempts = 0

    Dim fso As New Scripting.FileSystemObject

Retry:
    On Error Resume Next
    
    If lAttempts < lMaxAttempts Then
        lAttempts = lAttempts + 1
        If bVerbose Then Debug.Print "Attempting (" & lAttempts & " of " & lMaxAttempts & ") to call [" & TypeName(fso) & "].CreateFolder"
        
        '**********************************************************************************************************************************
        '* CORE OPERATION
        '**********************************************************************************************************************************
        fso.CreateFolder sFolder
        '**********************************************************************************************************************************
        '* END OF CORE OPERATION
        '**********************************************************************************************************************************
        
    End If

    If Err.Number <> 0 Then
        If lAttempts < lMaxAttempts Then
            '* still have some goes left, report (of verbose) then wait
            If bVerbose Then Debug.Print "(" & Err.Number & ") " & Err.Description & " whilst attempting to call [" & TypeName(fso) & "].CreateFolder"
    
            If dtInterval > 0 Then
                If bVerbose Then Debug.Print "reattempting after interval " & VBA.FormatDateTime(dtInterval)
                Application.Wait Now() + dtInterval
            End If
            Err.Clear
    
            GoTo Retry
        Else
            '* no more attempts left, throw to caller
            On Error GoTo 0
            Err.Raise Err.Number, Err.Source, Err.Description
        End If
    End If

SingleExit:
    Exit Function
    
ErrHandler:
    If bDebug Then
        Debug.Print "step-thru: (" & Err.Number & ") " & Err.Description & " whilst attempting to create folder '" & sFolder & "'"
        Stop
        Resume
    Else
        Err.Raise Err.Number, Err.Source, Err.Description
    End If
End Function

Private Function Interval(ByVal lIntervalSeconds As Long) As Date
    
    Dim lHours As Long
    lHours = lIntervalSeconds \ 3600
    
    Dim lMinutes As Long
    lMinutes = (lIntervalSeconds Mod 3600) \ 60
    
    Dim lSeconds As Long
    lSeconds = (lIntervalSeconds Mod 3600) Mod 60
    
    Dim sInterval As String
    sInterval = Right$("00" & lHours, 2) & ":" & Right$("00" & lMinutes, 2) & ":" & Right$("00" & lSeconds, 2)


    Interval = CDate(sInterval)
End Function