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