ADO Async Unlink Blocks

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 the 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

      

        
        
        
      

    

Then I created a surrogate connection 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 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

      

        
        
        
      

    

Then I update the connection source code:

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 reconfigured by the event clsADOAsyncConn.ConnectComplete

.

The only known issue with this solution is that even though it helps prevent blocking during normal code execution, it still calls the block when the process exits (at least until the last pending connection expires)