MS12-045 MDAC/WDAC

手順書などで使うキャプチャをしていた。

MS12-045 Microsoft Data Access Components の脆弱性により、リモートでコードが実行される
Criticalというのだから、更新プログラムの適用は必要なんだなぁと。で、Win7SP1でみてたら、こんな感じになる。

 なにか違うとと思ってたら6.1だった。

ADO Connection.Excuteでxlsx出力

メモ

ファイルがなければ新規に作成される。
シート名をテーブルとして扱う。

access2010 access2007 フォームがフォーカスを失っちゃう

MS Answersに投稿したのだけど、ADODB.RecordSetをフォームのレコードセットとした場合、フォームがアクティブにならない件。

access2010でSetFocusが使えない

こんな感じになる。フォームをクリックするなど操作しないとならなくなる。

Win7 SP1のADO関係のこと

なんだろう、Win7 SP1 ADO のキーワードでやたらPVが多い。のーんびり構えていた私にとってはちょっとびっくり。いろいろ情報を手繰っていると思いのほか影響が大きいようだ。
難しいことはわかる人に頼って読んだリンクとかをメモ。
An ADO application does not run on down-level operating systems after you recompile it on a computer that is running Windows 7 SP 1 or Windows Server 2008 R2 SP 1 or that has KB983246 installed (MSKB)

KB2517589では何故下位互換がなくなると説明しているか(新日々此何有哉)

KB2517589:ADOを使用しているアプリケーションの再コンパイルで互換性に問題が発生する(C#.NETでいく?)

KB2517589の検証(おもにAccess方面)(Creative Aid Blog)

Windows7 SP1とVB6で不具合(Microsoft Answers) 

IE9とAccess2003（Access Club）　IE9は関係なかったのだろう

今のところ、VBAの対応としては、実行時バインディングもしくは、Win7SP1以外の環境でコンパイルか。
"Type Mismatch" error message when you run a VBA macro in a 64-bit version of an Office 2010 application
このHotFixを当てていくのもなんだしな。と思ってたら、HotFixダウンロードページが5/2付で更新されている。XPとかのHotFixもダウンロードできてたのにな。 注意深く様子見だなぁ。

access2010 SharePointリスト ADO接続

Sub ADOTest()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim cnStr As String
    
    cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;WSS;" & _
            "IMEX=2;" & _
            "DATABASE=http://SharePointServerURL;" & _
            "LIST=ListName or ListGUID;" & _
            "VIEW=ViewGUID;"
            'IMEX=1 ReadOnly
    cn.Open cnStr
    rs.Open "Select * From XXX where ID=1;", cn, adOpenKeyset, adLockOptimistic
    rs.Update rs(1).Name, 1
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

access2010 access2007 ADO.Stream SaveToFile

添付ファイル型フィールドに保存されているファイルをローカルに保存する。

#If VBA7 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
#Else
Declare Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As Long)
#End If

Sub SaveToFileADOStream()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset, strm As New ADODB.Stream
    Dim rs2 As New ADODB.Recordset
    Dim fileBin() As Byte, fileBinSize As Long, bOffset As Long
    Dim fileBin2() As Byte, strSQL As String
    
    strSQL = "Select AttachmentField_Name As FileName " & _
             "From table_Name "
             
'このSQLだと超絶遅い
'    strSQL = "Select AttachmentField_Name.FileName As FileName, " & _
'             "AttachmentField_Name.FileData As FileData " & _
'             "From table_Name"
     
    Set cn = Application.CurrentProject.AccessConnection

    rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly
    Set rs2 = rs(0).Value

    fileBin = rs2.Fields("FileData")
    fileBinSize = UBound(fileBin)
    bOffset = fileBin(0)

    ReDim fileBin2(fileBinSize - bOffset)
    CopyMemory fileBin2(0), fileBin(bOffset), fileBinSize - bOffset

    With strm
        .Open
        .Type = adTypeBinary
        .Write fileBin2
        .SaveToFile CurrentProject.Path & "\" & _
                    rs2("FileName"), adSaveCreateOverWrite
        .Close
    End With

    Set strm = Nothing
    rs2.Close: Set rs2 = Nothing
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub

access2010 Windows7 SP1でADOに修正がはいる

Win7SP1がRCになったことで確認中。SP1に含まれるHotFixを覗いてみたところ影響ありそうなのが数件。多分、この件が解消。わーい。
"Type Mismatch" error message when you run a VBA macro in a 64-bit version of an Office 2010 application http://support.microsoft.com/kb/983246
RecordCount(ADO)の値Typeの件。Wiｎ7に限らず、offce2010(64bit)で影響するから、まぁXPは少ないだろうけど、64bitOS(Vista/Server2008とか)全部関係するでしょうな。

Option Compare Database
Option Explicit

Sub ADOtest()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    
    Set cn = Application.CurrentProject.AccessConnection
    rs.CursorLocation = adUseClient
    rs.Open "select * from table01", cn, adOpenKeyset, adLockOptimistic
    Debug.Print rs.RecordCount, TypeName(rs.RecordCount)
    
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub
'Win7の場合、rs.RecordCountは、Longlong → Win7SP1の場合、Long

Sub DAOtest()
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    
    Set db = CurrentDb
    Set rs = db.OpenRecordset("select * from table01")
    rs.MoveLast
    Debug.Print rs.RecordCount, TypeName(rs.RecordCount)
    
    Set db = Nothing
End Sub
'Win7/Win7SP1変わらず、Long

ADO関係のファイルバージョンが、6.1.7601.17105に。
その他accessに関係しそうなのが、
A computer that is running Windows 7 or Windows Server 2008 R2 takes four minutes to open a Microsoft Office 2003 document from a network share http://support.microsoft.com/kb/982860
4分かかるて、、、。Win7混じるとa2003が遅いって話しあったけどこれなのかな。

ADO レコードセットクローン

未検証

Function CloneRecordSet(SourceRecordset As ADODB.Recordset) As ADODB.Recordset
    Dim AdoStrm As New ADODB.Stream
    Set CloneRecordSet = New ADODB.Recordset
    AdoStrm.Open
    SourceRecordset.Save AdoStrm
    CloneRecordSet.Open AdoStrm
    AdoStrm.Close: Set AdoStrm = Nothing
End Function

VBA 配置済みコントロールからレコードセット作成

あまり覚えてないコード
非連結フォームで、エラー表示させたくないときのものだったかも

'*** セクション内コントロールから0件のレコードセット作成
Public Function EmptyRs(SrcSection As Section) As ADODB.Recordset
On Error GoTo ErrLabel
    Dim ctr As Control
    Dim rs As New ADODB.Recordset
    For Each ctr In SrcSection.Controls
        rs.Fields.Append ctr.ControlSource, adVarChar, 1
    Next
    rs.Open
    If rs.Fields.Count > 0 Then
        Set EmptyRs = rs
    Else
        Set EmptyRs = Nothing
    End If
    Set rs = Nothing
Exit Function
ErrLabel:
    If Err.Number = 438 Then Resume Next
End Function

access2010 ADO非同期処理 メモ Form.Open

Option Compare Database
Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private WithEvents cnCls1 As Class_ADOConnectionAsyncWithDialog

Private cnCondition As Boolean
Private OpenCancel As Boolean
Private cnErrMsg As String

Private Sub SetInit()
    Set cnCls1 = New Class_ADOConnectionAsyncWithDialog
    cnErrMsg = ""
    cnCls1.ConnectionStart
End Sub

Private Sub cnCls1_Connected(cnStatus As ADODB.EventStatusEnum, cnError As ADODB.Error)
    If cnStatus = adStatusOK Then
        cnCls1.ExecQueryReadOnly "procedurestring"
    Else
        OpenCancel = True
        cnErrMsg = "Connection Error:" & cnError.Description
        cnCls1.ConnectionClose'cnErrMsg代入を先にしないとConnectionCloseが先に実行される場合がある
    End If
End Sub

Private Sub cnCls1_ExecuteComplete(cnStatus As ADODB.EventStatusEnum, ResultRS As ADODB.Recordset, ResultRecordsAffected As Long, cnError As ADODB.Error)
    If cnStatus = adStatusOK Then
        'ここでいろいろセッティング
    Else
        OpenCancel = True
        cnErrMsg = "Execute Error:" & cnError.Description
    End If
    cnCls1.ConnectionClose 
End Sub

Private Sub cnCls1_DisConnected()
    Set cnCls1 = Nothing
    cnCondition = True
End Sub

Private Sub Form_Open(Cancel As Integer)
On Error GoTo Errhnd
    cnCondition = False
    OpenCancel = False
    SetInit
    While cnCondition = False'ここでLoopさせて待機
        DoEvents
        Sleep 100
    Wend
    If Not cnErrMsg = "" Then MsgBox cnErrMsg
    Cancel = OpenCancel
Exit Sub
Errhnd:
    Cancel = True
End Sub

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

access2010 MySQL接続でのメモ

Option Compare Database
Option Explicit

Const cnString = "Driver={MySQL ODBC 5.1 Driver};" & _
                 "server=mySQLServer;" & _
                 "port=3306;" & _
                 "database=test;" & _
                 "uid=testuser;" & _
                 "pwd=password;"

Sub test()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    cn.Open cnString
    rs.CursorLocation = adUseClient
    rs.Open "select * from test_table;", cn
    Debug.Print "rs.RecordCount", rs.RecordCount, TypeName(rs.RecordCount)
    rs.Close: cn.Close
    Set rs = Nothing: Set cn = Nothing
End Sub

このコード実行結果：rs.RecordCount 31 LongLong
recordcountにはLongLongで値が戻る。

なので、格納先はLongPtrを使用/Longにキャスト/Variantで受けてDecimal。
64bit環境のみならばLongLong使用可。

<追記>
Win7SP1時点で、ADOに修正が入る。修正以降は、LongLongが戻らず、Longで戻る模様。

VBA ADOconnectionString memo

Option Compare Database
Option Explicit

'Public Const cnString = ""


'********** MySQL **********
'Public Const cnString = "Driver={MySQL ODBC 5.1 Driver};" & _
                        "server=server_name;" & _
                        "port=3306;" & _
                        "database=DBName;" & _
                        "uid=Account_Name;" & _
                        "pwd=Password;" & _
                        "option=3;"

'Public Const cnString = "Driver={MySQL ODBC 3.51 Driver};" & _
                        "Server=myServerAddress;" & _
                        "Database=myDataBase;" & _
                        "User=myUsername;" & _
                        "Password=myPassword;" & _
                        "Option=3;"

'********** Access **********
'Public Const cnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=C:\myFolder\myAccessfile.accdb;" & _
                        "Persist Security Info=False;"

'Public Const cnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=C:\myFolder\myAccessfile.accdb;" & _
                        "Jet OLEDB:Database Password=MyDbPassword;"

'Public Const cnString = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                        "DBQ=C:\myFolder\myAccessfile.accdb;"

'Public Const cnString = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                        "DBQ=C:\myFolder\myAccessfile.accdb;" & _
                        "Pwd=MyDbPassword;" & _
                        "Uid="
'********** MS-SQL **********
'Public Const cnString = "Driver={SQL Server Native Client 10.0};" & _
                        "Server=myServerAddress;" & _
                        "Database=myDataBase;" & _
                        "Uid=myUsername;" & _
                        "Pwd=myPassword;"
'
'Are you using SQL Server 2008 Express?
'Don't miss the server name syntax Servername\SQLEXPRESS
'where you substitute Servername with the name of the
'computer where the SQL Server 2008 Express installation resides.
'
'Public Const cnString = "Driver={SQL Server Native Client 10.0};" & _
                        "Server=myServerAddress;" & _
                        "Database=myDataBase;" & _
                        "Trusted_Connection=yes;"
'
'Equivalent key-value pair: "Integrated Security=SSPI" equals "Trusted_Connection=yes"

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

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

CtrEnabledChangeで引数Meを投げると、元フォーム詳細上コントロールをコレクションに格納してEnabledをFalseに設定
再び投げるとコレクション内コントロールのEnabledをTrueに再設定 

Option Compare Database
Option Explicit

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

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******"
Application.Echo False
    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******"
Application.Echo True
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)
    Debug.Print "DisConnected:" & Now()
    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)
    Debug.Print "WillConnect:" & Now()
    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()
    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()
    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

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
    Debug.Print "Cancel:" & Now()
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

Public Sub CtrEnabledChange(Frm As Form)
Dim Ctr As Control
DoCmd.RunCommand acCmdSelectRecord
    If CtrCollection Is Nothing Then
        Set CtrCollection = New Collection
        For Each Ctr In Frm.詳細.Controls
            If CtrEnabled(Ctr) Then
                If Ctr.Enabled = True Then
                    Ctr.Enabled = False
                    CtrCollection.Add Ctr
                End If
            End If
        Next
    Else
        For Each Ctr In CtrCollection
            Ctr.Enabled = True
        Next
        Set CtrCollection = Nothing
    End If
End Sub

Private Function CtrEnabled(Ctr As Control) As Boolean
On Error GoTo ErrLabel
    CtrEnabled = False
    If Ctr.Enabled = True Then CtrEnabled = True
    Exit Function
ErrLabel:
    CtrEnabled = False
End Function

連続絞り込み

Private Sub Form_Load()
Dim rs As New ADODB.Recordset
Dim cn As New ADODB.Connection

Set cn = Application.CurrentProject.Connection
rs.CursorLocation = adUseClient
rs.Open "SQLstring", cn
Set Me.listbox0.Recordset = rs
rs.Close:cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

Private Sub textbox0_Change()
Dim rs As New ADODB.Recordset
Set rs = Me.listbox0.Recordset
rs.Filter = "F1 like """ & Me.textbox0.Text & "*"""
Set Me.listbox0.Recordset = rs
Set rs = Nothing
End Sub

Private Sub textbox0_GotFocus()
Me.listbox0.Visible = True
End Sub

Private Sub textbox0_LostFocus()
Me.listbox0.Visible = False
End Sub 

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

MS-Access+ADO非同期処理 Form_dialogbusy

btnCancel押下で、イベントを発生させ共有先でイベントを把握。
表示キャプションはメインフォームの接続イベントで変更するから、カスタムプロパティを使用 
配置コントロール

• label1
• btnCancel 

Option Compare Database
Option Explicit

Public Event btnCancelClick()

Property Let oCaption(i As String)
     Me.Caption = i
End Property
Property Let oLabelCaption(i As String)
    Me.label1.Caption = i
End Property

Private Sub btnCancel_Click()
    RaiseEvent btnCancelClick
End Sub

Private Sub Form_Load()
    Me.oCaption = ""
    Me.oLabelCaption = ""
    Me.RecordSelectors = False
    Me.NavigationButtons = False
    Me.TimerInterval = 500
End Sub

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

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

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