MS-Access+ADO非同期処理 Form_main

WithEventsでAsyncClassとBusyダイアログのイベントを使用
タイマイベントを使うことで、処理時間が長くなった場合のみダイアログを表示。
ダイアログを開いたもしくは閉じた時点でTimerInterval=0とし表示は一度だけ。
配置コントロール

• ListBox1
• btnExec
• btnClose

Option Compare Database
Option Explicit

Private WithEvents cls1 As AsyncClass
Private WithEvents dlg As Form_dialogbusy

Dim cnStatemsg As String

Private Sub ContentsClear()
    Set Me.listbox1.Recordset = Nothing
    Me.listbox1.Requery
    Me.listbox1 = Null
End Sub

Private Sub ContentsSet()
    If Not cls1 Is Nothing Then Exit Sub
    Set cls1 = New AsyncClass
    Call cls1.ConnectionStart
End Sub

Private Function IsNotEnableQuery() As Boolean
    If cls1 Is Nothing Then
        IsNotEnableQuery = False
    Else
        IsNotEnableQuery = True
    End If
End Function

Private Sub btnClose_Click()
    If IsNotEnableQuery Then Exit Sub
    DoCmd.Close
End Sub

Private Sub btnExec_Click()
    If IsNotEnableQuery Then Exit Sub
    ContentsClear
    ContentsSet
End Sub

Private Sub cls1_WillConnect()
    Debug.Print "WillConnect:" & Now()
    Me.TimerInterval = 500
    Call DialogUpdate("Connecting...")
End Sub

Private Sub cls1_Connected(cnStatus As ADODB.EventStatusEnum, cnError As ADODB.Error)
    Debug.Print "ConnectComplete:" & Now() & " Status:" & cnStatus
    Select Case cnStatus
        Case adStatusOK
            If Not dlg Is Nothing Then
                dlg.oCaption = "Executing"
                dlg.oLabelCaption = "Executing ."
            End If
            Call cls1.ExecQuery("SQLstring")
        Case adStatusErrorsOccurred
            Debug.Print "Error:" & cnError.Description
            cls1.ConnectionClose
        Case Else
            Debug.Print "Connection Error:" & cnError.Description
            cls1.ConnectionClose
    End Select
End Sub

Private Sub cls1_WillExecute()
    Debug.Print "WillExecute:" & Now()
    Call DialogUpdate("Executing...")
End Sub

Private Sub cls1_ExecuteComplete(cnStatus As ADODB.EventStatusEnum, ResultRS As ADODB.Recordset, cnError As ADODB.Error)
    Debug.Print "ExecuteComplete:" & Now() & " status:" & cnStatus
    Select Case cnStatus
        Case adStatusOK
            Set Me.listbox1.Recordset = ResultRS
            Me.listbox1.ColumnCount = ResultRS.Fields.Count
        Case Else
            Debug.Print "Error:" & cnError.Description
    End Select
    cls1.ConnectionClose
End Sub

Private Sub cls1_DisConnected()
    Debug.Print "DisConnected:" & Now()
    DialogClose
    Set cls1 = Nothing
End Sub

Private Sub dlg_btnCancelClick()
    cls1.ConnectionCancel
End Sub

Private Sub Form_Close()
    On Error Resume Next
    Set cls1 = Nothing
End Sub

Private Sub Form_Timer()
    DialogOpen
End Sub

Private Sub DialogOpen()
    If Not dlg Is Nothing Then
        Me.TimerInterval = 0
    Else
        Set dlg = New Form_dialogbusy
        dlg.oCaption = cnStatemsg
        dlg.oLabelCaption = cnStatemsg
        dlg.Visible = True
    End If
End Sub

Private Sub DialogClose()
    If Not dlg Is Nothing Then
        Set dlg = Nothing
    End If
    Me.TimerInterval = 0
End Sub

Private Sub DialogUpdate(msg As String)
    cnStatemsg = msg
    If Not dlg Is Nothing Then
        dlg.oCaption = cnStatemsg
        dlg.oLabelCaption = cnStatemsg
    End If
End Sub