Article ID: 190606
Article Last Modified on 3/2/2005
If adStatus = adStatusErrorsOccurred Then
If pError.Number = -2147217871 Then
Debug.Print "Execute timed-out"
End If
End If
Microsoft ActiveX Data Objects Library
Textbox
Name: txtMessage
Make this Textbox large enough to display a reasonable message
Command1
Name: cmdRetry
Caption: Retry
Command2
Name: cmdCancel
Caption: Cancel
Option Explicit
Public fCancel As Boolean
Private Sub cmdCancel_Click ()
fCancel = True
Me.Visible = False
End Sub
Private Sub cmdRetry_Click ()
fCancel = False
Me.Visible = False
End Sub
Command1
Name: cmdDetect
Caption: Detect Timeout
Command2
Name: cmdChoose
Caption: Time-out?
Option Explicit
Dim WithEvents cn As ADODB.Connection, rs As ADODB.Recordset
Private Sub cmdChoose_Click()
Dim SQL As String
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open "dsn=mydsn;database=pubs" ' *** change connect string ***
'CommandTimeout is optional; default is 30 seconds.
cn.CommandTimeout = 15
'
' This query must exceed the Timer1.Interval in order to test.
'
SQL = "SELECT authors.* FROM authors, titles a, titles b"
rs.Open SQL, cn, adOpenKeyset, adLockOptimistic, adAsyncExecute
Timer1.Interval = 2000
End Sub
Private Sub cn_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)
If adStatus = adStatusErrorsOccurred Then
If pError.Number = -2147217871 Then
Debug.Print "Execute timed-out"
End If
End If
Timer1.Interval = 0 ' turn off timer for async code
if adStatus = adStatusOK Then
If pRecordset.State = adStateOpen Then
'
' Execute code now async query has completed.
'
Debug.Print "Query Complete."
End If
End If
End Sub
Private Sub cmdDetect_Click()
Dim SQL As String
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
cn.Open "dsn=mydsn;database=pubs" ' *** change connect string ***
'The below is set low for demonstration purposes, it is optional.
cn.CommandTimeout = 2
SQL = "SELECT authors.* FROM authors, titles a, titles b"
rs.Open SQL, cn, adOpenKeyset, adLockOptimistic, adAsyncExecute
End Sub
Private Sub Timer1_Timer()
Select Case rs.State
Case adStateConnecting, adStateExecuting, adStateFetching
If SafeMsgBox("Query has timed-out.") = vbCancel Then
rs.Cancel
Timer1.Interval = 0
End If
Case Else
Timer1.Interval = 0 ' catch-all
End Select
End Sub
Private Function SafeMsgBox(ByVal Message As String) As Long
Load Form2
Form2.txtMessage = Message
Form2.Show vbModal
SafeMsgBox = IIf(Form2.fCancel, vbCancel, vbRetry)
Unload Form2
End Function
Keywords: kbdatabase kbprb KB190606