MS- Access+ADO非同期処理 AsyncClass改2

状態ダイアログ表示を含んだADO接続クラス
---クラス本体---

Option Compare Database
Option Explicit

Private WithEvents sDialog As Form_StatusDialog

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, ResultRecordsAffected As Long, 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()
    On Error Resume Next
    DialogClose
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
Debug.Print "******ClassTerminate******"
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)
    Debug.Print "WillConnect:" & Now()
    DialogShow
    sDialog.Status = "Connecting..."
    RaiseEvent WillConnect
End Sub

Private Sub cn_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    Debug.Print "ConnectComplete:" & Now()
    sDialog.Status = "Connected..."
    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)
    Debug.Print "WillExecute:" & Now()
    sDialog.Status = "Executing..."
    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)
    Debug.Print "ExecuteComplete:" & Now()
    
    RaiseEvent ExecuteComplete(adStatus, pRecordset, RecordsAffected, pError)
End Sub

Private Sub cn_Disconnect(adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
    Debug.Print "DisConnected:" & Now()
    RaiseEvent DisConnected
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

Private Sub ConnectionCancel()
    Debug.Print "Cancel:" & Now()
    If cn.State = adStateExecuting And rs.State = adStateClosed Then
        sDialog.Status = "Try Cancel..."
        DoEvents
        cn.Cancel
    ElseIf cn.State = adStateOpen And rs.State = adStateExecuting Then
        sDialog.Status = "Try Cancel..."
        DoEvents
        rs.Cancel
    End If
End Sub

Public Sub ConnectionClose()
On Error Resume Next
    rs.Cancel
    rs.Close
    cn.Cancel
    cn.Close
RaiseEvent DisConnected
End Sub

Private Sub DialogShow()
    Set sDialog = New Form_StatusDialog
     sDialog.Modal = True
    sDialog.TimerInterval =  1000　’ダイアログ表示までのTimeInterval
End Sub

Private  Sub DialogClose()
    sDialog.TimerInterval = 0
    sDialog.Modal  = False
    sDialog.Visible = False
    Set sDialog = Nothing
End  Sub

Private Sub sDialog_DialogbtnCancelClick()
    ConnectionCancel
End Sub

Private Sub sDialog_DialogTimerEvent()
    If sDialog.Visible = False Then
        sDialog.Visible = True
        sDialog.TimerInterval = 500　’ダイアログアニメーション用TimeInterval
    End If
End Sub

---ダイアログフォーム---
Option Compare Database
Option Explicit

Public Event DialogTimerEvent()
Public Event DialogbtnCancelClick()

Dim dcls As DefalultFormClass
Dim RectangleArray(7) As Rectangle
Dim counter As Integer

Property Let Status(i As String)
    Me.labelStatus.Caption = i
End Property

Private Sub btnCancel_Click()
    RaiseEvent DialogbtnCancelClick
End Sub

Private Sub Form_Load()
DoCmd.RunCommand acCmdSelectRecord
    Set dcls = New DefalultFormClass
    dcls.BindForm Me
    
    Dim i As Integer
    For i = 0 To 7
        Set RectangleArray(i) = Me.Controls("ボックス" & i)
    Next
End Sub

Private Sub Form_Timer()
    RaiseEvent DialogTimerEvent
’以下アニメーション用コード    
    On Error GoTo ErrLabel
    Dim i As Integer
    i = counter Mod 8
    RectangleArray(i).Visible = Not RectangleArray(i).Visible
    counter = counter + 1
    Exit Sub
ErrLabel:
    counter = 0
    Resume Next
End Sub