ADO Async Connection Cancellation Blocks - database

Question

When I try to cancel an async ADO connection to some DB server that is offline (or not responding), the Cancel method of the ADODB.Connection object blocks for the set time-out period.
I do the async connection like this:
Set Connection = New ADODB.Connection
Connection.Provider = "SQLOLEDB"
Connection.ConnectionTimeout = 60
Connection.ConnectionString = "Initial Catalog=" & RTrim(DBName) & _
";Data Source=" & RTrim(DBServerName) & ";Integrated Security = SSPI"
Connection.Open , , , adAsyncConnect
And then later call the following to cancel/close the connection:
If (Connection.State And adStateConnecting) = adStateConnecting Then
' ==== CONNECTION BLOCKS HERE ======
Connection.Cancel
End If
If (Connection.State And adStateOpen) = adStateOpen Then
Connection.Close
End If
Set Connection = Nothing
Is there a way to not let the Cancel method block?

Answer 1

I found my own solution at the end. Well, at least an acceptable workaround.
First I created a module that could cancel/close the connection in a timer (thanks to an idea from a Code Project article):
Option Explicit
' Timer API:
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) _
As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
' Collection of connections to cancel
Private m_connections As Collection
' The ID of our API Timer:
Private m_lTimerID As Long
Private Sub TimerProc(ByVal lHwnd As Long, ByVal lMsg As Long, _
ByVal lTimerID As Long, ByVal lTime As Long)
On Error GoTo ErrH:
Dim cnx As ADODB.Connection
' Remove the timer
KillTimer 0, lTimerID
If Not m_connections Is Nothing Then
With m_connections
Do While .Count > 0
Set cnx = .Item(1)
.Remove 1
TryCancelOrCloseConnection cnx
Loop
End With
If m_connections.Count = 0 Then
Set m_connections = Nothing
End If
End If
' Let the next call to CancelOrCloseAsync create a new timer
m_lTimerID = 0
Exit Sub
ErrH:
' Let the next call to CancelOrCloseAsync create a new timer
m_lTimerID = 0
Debug.Print "Error closing connetions timer: " & Err.Description
End Sub
Private Sub TryCancelOrCloseConnection(cnx As ADODB.Connection)
On Error GoTo ErrH
If Not cnx Is Nothing Then
If (cnx.State And adStateConnecting) = adStateConnecting Then
' The call to Cancel here blocks this execution path (until connection time-out),
' but we assume it internally calls DoEvents, because (even though it blocks here) messages get pumped.
cnx.Cancel
End If
' If the connection actually made it to an open state, we make sure it is closed
If (cnx.State And adStateOpen) = adStateOpen Then
cnx.Close
End If
End If
Exit Sub
ErrH:
Debug.Print "ADO Connection Cancel/Close error " & Err.Description
' We deliberately suppress the error here.
' The reason is that accessing the Connection.State property, while there was an error when
' connecting, will raise an error. The idea of this method is simply to make sure we close/cancel
' the pending connection if there was no connection error.
End Sub
Public Sub CancelOrCloseAsync(cnx As ADODB.Connection)
If Not cnx Is Nothing Then
' Add cnx to the collection of connections to cancel
If m_connections Is Nothing Then
Set m_connections = New Collection
End If
m_connections.Add cnx
' Create a timer to start cancelling the connection(s), but only if one is not already busy
' We need to cast the process off to a timer because the Connection.Cancel blocks the
' normal execution path.
If m_lTimerID = 0 Then
m_lTimerID = SetTimer(0, 0, 1, AddressOf TimerProc)
End If
End If
End Sub
I then created a Connection surrogate class called clsADOAsyncConn
Private WithEvents Connection As ADODB.Connection
Private m_Pending As Boolean
Public Event ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
Public Property Get Provider() As String
Provider = Connection.Provider
End Property
Public Property Let Provider(ByVal val As String)
Connection.Provider = val
End Property
Public Property Get ConnectionTimeout() As Long
ConnectionTimeout = Connection.ConnectionTimeout
End Property
Public Property Let ConnectionTimeout(ByVal val As Long)
Connection.ConnectionTimeout = val
End Property
Public Property Get ConnectionString() As String
ConnectionString = Connection.ConnectionString
End Property
Public Property Let ConnectionString(ByVal val As String)
Connection.ConnectionString = val
End Property
Public Sub OpenAsync(Optional ByVal UserID As String = "", Optional ByVal Password As String = "")
Connection.Open , UserID, Password, adAsyncConnect
m_Pending = True
End Sub
Private Sub Class_Initialize()
Set Connection = New ADODB.Connection
End Sub
Private Sub Class_Terminate()
If Not Connection Is Nothing And m_Pending Then
' While the connection is still pending, when the user of this class reminates the refernce
' of this class, we need to cancel it in its own timer loop or else the caller's code will
' block at the point where the refernce to this object is de-referenced.
CancelOrCloseAsync Connection
End If
End Sub
Private Sub Connection_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
m_Pending = False
' Notify the object client of the connection state
RaiseEvent ConnectComplete(pError, adStatus, pConnection)
End Sub
I then update my original connection code to this:
Set Connection = New clsADOAsyncConn
Connection.Provider = "SQLOLEDB"
Connection.ConnectionTimeout = 60
Connection.ConnectionString = "Initial Catalog=" & RTrim(DBName) & _
";Data Source=" & RTrim(DBServerName) & ";Integrated Security = SSPI"
Connection.OpenAsync
The actual connection is then retuned by the clsADOAsyncConn.ConnectComplete event.
The only known issue with this solution is that even though it helps prevent a block in normal execution of code, it still causes a block when the process exits (at least until the last pending connection(s) times out)