ADO Async Connection Cancellation Blocks

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)