Question

当我尝试取消与某个脱机（或没有响应）的数据库服务器的异步ADO连接时，Cancel对象的ADODB.Connection方法会阻止设置的超时时间。< / p>

我像这样执行异步连接：

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

然后调用以下内容取消/关闭连接：

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

有没有办法不让Cancel方法阻止？

Answer 1

我最后找到了自己的解决方案。好吧，至少是一个可接受的解决方法。

首先，我创建了一个可以在计时器中取消/关闭连接的模块（感谢来自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

然后我创建了一个名为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

然后我将原始连接代码更新为：

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

然后clsADOAsyncConn.ConnectComplete事件重新启动实际连接。

此解决方案唯一已知的问题是即使它有助于防止代码正常执行中的阻塞，但在进程退出时仍会导致阻塞（至少直到最后一个挂起的连接超时）

ADO异步连接取消阻止

1 个答案: