ADO - CommandTimeOut

Dim blnCancel               As Boolean
Dim cnQuery                 As ADODB.Connection
Dim WithEvents rstQuery     As ADODB.Recordset
Dim lngRecordsFetched       As Long

Private Sub Form_Load()
    Set cnQuery = New ADODB.Connection
    cnQuery.CursorLocation = adUseClient
    
    Set rstQuery = New ADODB.Recordset
    rstQuery.CursorLocation = adUseClient
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set rstQuery = Nothing
    Set cnQuery = Nothing
End Sub

Private Sub cmdCancel_Click()
    blnCancel = True
End Sub

Private Sub cmdRunAsyncQuery_Click()
    cmdRunAsyncQuery.Enabled = False
    cmdCancel.Enabled = True
    
    cnQuery.ConnectionString = "Provider=SQLOLEDB.1;Password=ReadOnly;Persist Security Info=True;User ID=ReadOnly;Initial Catalog=Fire;Data Source=OMSDEV"
    cnQuery.Open , , , adAsyncExecute '<- Asynchronous Connection
    Do While cnQuery.State = adStateConnecting '<- While trying to connect, DoEvents
        DoEvents
    Loop
    
    'If a previously canceled query was run, clear the grid
    If rstQuery.State = adStateOpen Then rstQuery.Close
    grdData.Clear
    DoEvents

    rstQuery.Open "SELECT * FROM CadSegment", cnQuery, adOpenForwardOnly, adLockReadOnly, adAsyncFetch '<- Fetch records asynchronously in the background

    Do While rstQuery.State = adStateExecuting Or rstQuery.State = adStateOpen + adStateFetching '<- If the query is trying to execute or has finished but is still fetching, then DoEvents
        DoEvents
        If blnCancel Then '<- the user clicked the cancel button so cancel the query
            rstQuery.Cancel
            Set rstQuery.ActiveConnection = Nothing
            cnQuery.Cancel
            cnQuery.Close
            blnCancel = False 'Reset the flag
        Else
            If lngRecordsFetched > 0 Then '<- the query is in the process of fetching
                txtStatusBar.Text = "Records Fetched: " & lngRecordsFetched
            Else '<- the query is still in the process of executing
                txtStatusBar.Text = "Executing Query..."
            End If
        End If
        DoEvents
    Loop
    
    Set grdData.Recordset = rstQuery
    
    Set rstQuery.ActiveConnection = Nothing
    If cnQuery.State = adStateOpen Then cnQuery.Close
    cmdRunAsyncQuery.Enabled = True
    cmdCancel.Enabled = False
End Sub

'This is a callback routine. It monitors the fetching progress.
'I'm setting a global counter which is used in the above routine to display the progress.
Private Sub rstQuery_FetchProgress(ByVal Progress As Long, ByVal MaxProgress As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
  On Error Resume Next
    lngRecordsFetched = MaxProgress
End Sub