ADO非同期レコードセット取得 access VBA

クラスモジュール
Option Compare Database
Option Explicit

Public Event RsComplete(ByVal str As String)
Public Event RsFetch(ByVal RC As Long)

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

Private Sub Class_Initialize()
Dim cnStr as String
cnStr="Connection_String"
Set cn = New ADODB.Connection
cn.Open cnStr
End Sub

Private Sub Class_Terminate()
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

Public Sub teststart()
Set rs = New ADODB.Recordset
With rs
.CursorLocation = adUseClient
.Open "SQL_string", cn, adOpenForwardOnly, adLockReadOnly, adAsyncFetch'(もしかするとadAsyncExecute)
End With
End Sub

Private Sub rs_FetchComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
RaiseEvent RsComplete("done")
End Sub

Private Sub rs_FetchProgress(ByVal Progress As Long, ByVal MaxProgress As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
RaiseEvent RsFetch(Progress)
End Sub

フォームモジュール
Option Compare Database
Option Explicit

Private WithEvents ac As AsyncClass

Private Sub tra2_RsComplete(ByVal str As String)
MsgBox str
Set ac = Nothing
End Sub

Private Sub tra2_RsFetch(ByVal RC As Long)
On Error GoTo hoge
Me.ProgressBar1.Value = RC
Exit Sub
hoge:
Me.ProgressBar1.Max = Me.ProgressBar3.Max + 5000
End Sub

Private Sub コマンド0_Click()
Me.ProgressBar1.Value = 0
Me.ProgressBar1.Max = 10000
Me.ProgressBar1.Min = 0
Set ac = New AsyncClass
ac.teststart
End Sub

ADO非同期コネクション access VBA

クラスモジュール AsyncClass
Option Compare Database
Option Explicit

Public Event CnResult(ByVal Result As Boolean, ByVal Err As ADODB.Error)
Public Event CnStart(ByVal str As String)

Private WithEvents cn As ADODB.Connection

Private Sub Class_Initialize()
Dim cnStr as String
cnStr="Connection_String"
Set cn = New ADODB.Connection
cn.ConnectionString = cnStr
End Sub

Private Sub Class_Terminate()
On Error Resume Next
cn.Close
Set cn = Nothing
End Sub

Private Sub cn_ConnectComplete(ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pConnection As ADODB.Connection)
Dim Result As Boolean
Select Case adStatus
　Case adStatusOK
　　Result = True
　Case Else
　　Result = False
End Select
RaiseEvent CnResult(Result, pError)
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 CnStart("test_Start")
End Sub

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

フォームモジュール
Option Compare Database
Option Explicit

Private WithEvents ac As AsyncClass

Private Sub Form_Load()
コマンド0_Click
End Sub

Private Sub Form_Timer()
Me.lblresult.Caption = Me.lblresult.Caption & "."
End Sub

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

Private Sub ac_CnResult(ByVal Result As Boolean, ByVal Err As ADODB.Error)
Me.TimerInterval = 0
If Result Then
　Me.lblresult.Caption = "OK"
Else
　Me.lblresult.Caption = "NG" & Err.Description
End If
End Sub

Private Sub ac_CnStart(ByVal str As String)
Me.lblresult.Caption = str
Me.TimerInterval = 1000
End Sub

Private Sub コマンド0_Click()
Me.lblresult.Caption = ""
Set ac = New AsyncClass
ac.teststart
End Sub