MS-Access+ADO非同期処理 AsyncClass

MS-Access+ADOで非同期接続
Formタイマーイベントを使用してBusyダイアログをモーダル表示
Busyダイアログにはキャンセルボタンを用意し、コネクションもしくはクエリをキャンセル

Option Compare Database
Option Explicit

Private WithEvents cn As ADODB.Connection
Private rs As ADODB.Recordset

Public Event WillConnect()
Public Event Connected(cnStatus As ADODB.EventStatusEnum, cnError As ADODB.Error)
Public Event WillExecute()
Public Event ExecuteComplete(cnStatus As ADODB.EventStatusEnum, ResultRS As ADODB.Recordset, cnError As ADODB.Error)
Public Event DisConnected()

Private Sub Class_Initialize()
Debug.Print "******ClassInitialize******"
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    cn.ConnectionString = ”ConnectionString”
    rs.CursorLocation = adUseClient
End Sub

Private Sub Class_Terminate()
Debug.Print "******ClassTerminate******"
On Error Resume Next
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

Private Sub cn_Disconnect(adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    RaiseEvent DisConnected
End Sub

Private Sub cn_WillConnect(ConnectionString As String, UserID As String, Password As String, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    RaiseEvent WillConnect
End Sub

Private Sub cn_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    RaiseEvent Connected(adStatus, pError)
End Sub

Private Sub cn_WillExecute(Source As String, CursorType As ADODB.CursorTypeEnum, LockType As ADODB.LockTypeEnum, Options As Long, adStatus As ADODB.EventStatusEnum, ByVal pCommand As ADODB.Command, ByVal pRecordset As ADODB.Recordset, ByVal pConnection As ADODB.Connection)
    RaiseEvent WillExecute
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)
    RaiseEvent ExecuteComplete(adStatus, pRecordset, pError)
End Sub

Public Sub ConnectionStart()
    cn.Open , , , adAsyncConnect
End Sub

Public Sub ExecQuery(SQLstring As String)
    rs.Open SQLstring, cn, adOpenKeyset, adLockOptimistic, adAsyncExecute
End Sub

Public Sub ExecQueryReadOnly(SQLstring As String)
    rs.Open SQLstring, cn, adOpenForwardOnly, adLockReadOnly, adAsyncExecute
End Sub

Public Sub ConnectionCancel()
    If cn.State = adStateConnecting And rs.State = adStateClosed Then
        RaiseEvent DisConnected
    ElseIf cn.State = adStateExecuting And rs.State = adStateClosed Then
        cn.Cancel
        cn.Close
    ElseIf cn.State = adStateOpen And rs.State = adStateExecuting Then
        rs.Cancel
        cn.Close
    End If
End Sub

Public Sub ConnectionClose()
On Error Resume Next
    If cn.State = adStateOpen Then
        cn.Close
    End If
On Error GoTo 0
    RaiseEvent DisConnected
End Sub