Fluent UI マークアップから列挙 VBA

Fluent UI　マークアップからコントロール毎のidを列挙
たまに使いたい時がある
UsysRibbonsからxmlを取得してcollectionに格納するのもいいかも知れん
object.InvalidateControl メソッドでeditBoxだけ一括処理とか

'参照：Microsoft XML v6.0
Sub listUpIdByControl()
Dim xdoc As New DOMDocument
Dim i As Integer
Dim node As IXMLDOMNode
Dim nodes As IXMLDOMNodeList
Dim xmlattr As IXMLDOMAttribute

xdoc.async = True
xdoc.Load "directory+filename"

Set nodes = xdoc.DocumentElement.SelectNodes("//button") ' "//control_type"
For i = 1 To nodes.Length
    Set node = nodes(i - 1)
    Set xmlattr = node.Attributes.getNamedItem("id")
    Debug.Print node.nodeName, xmlattr.Value
Next
End Sub

Sub listUpId(targetXML As String, targetElement As String)
Dim xdoc As New DOMDocument
Dim i As Integer
Dim node As IXMLDOMNode
Dim nodes As IXMLDOMNodeList
Dim xmlattr As IXMLDOMAttribute

xdoc.LoadXML targetXML

Set nodes = xdoc.DocumentElement.SelectNodes("//" & targetElement)
For i = 1 To nodes.Length
    Set node = nodes(i - 1)
    Set xmlattr = node.Attributes.getNamedItem("id")
    Debug.Print node.nodeName, xmlattr.Value
Next
End Sub

Ribbon CustomUI

印刷プレビューとかで使うRibbonを考えているところ
リボンに配置したコントロールは、VBAから直接操作できないから
getEnabledとかgetVisibleなどget～のコールバックを指定
object.InvalidateControl ItemID　で再キャッシュする
object.Invalidateで全体を再キャッシュ

'---- Module ----
Option Compare Database
Option Explicit

Private Rbtab02 As IRibbonUI

Sub OnLoad_Ribbon02(Ribbon As IRibbonUI)
    Set Rbtab02 = Ribbon
End Sub

Sub setLabel(control As IRibbonControl, ByRef label)
    Select Case control.id
        Case "dropdown01"
            label = "プリンタ"
    End Select
End Sub

Sub setScreentip(control As IRibbonControl, ByRef screentip)
    Select Case control.id
        Case "dropdown01"
            screentip = "出力先プリンタ選択"
    End Select
End Sub

Sub setItemCount(control As IRibbonControl, ByRef count)
    Select Case control.id
        Case "dropdown01"
            count = Application.Printers.count
    End Select
End Sub

Sub setItemLabel(control As IRibbonControl, index As Integer, ByRef label)
    Select Case control.id
        Case "dropdown01"
            label = Application.Printers(index).DeviceName
    End Select
End Sub

Sub setItemId(control As IRibbonControl, index As Integer, ByRef id)
    Select Case control.id
        Case "dropdown01"
            id = Application.Printers(index).DeviceName
    End Select
End Sub

Sub setItemImage(control As IRibbonControl, index As Integer, ByRef image)
    Select Case control.id
        Case "dropdown01"
            image = "FilePrint"
    End Select
End Sub

Sub setItemDefault(control As IRibbonControl, ByRef index)
    Select Case control.id
        Case "dropdown01"
            index = Application.Printer.DeviceName
    End Select
End Sub

Sub selectPrinter(control As IRibbonControl, selectedId As String, selectedIndex As Integer)
    MsgBox control.id & vbTab & selectedId & vbTab & selectedIndex
End Sub

Sub RibbonUpdate()
    Rbtab02.Invalidate
End Sub


Sub ElementUpdate(elementId as String)
    Rbtab02.InvalidateControl elementId
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" 
          onLoad="OnLoad_Ribbon02">
  <ribbon startFromScratch="true">
    <tabs>
      <tab id="tab01" label="Tab01">
        <group id="g0102" label="g0102">
          <dropDown id="dropdown01" 
                    getLabel="setLabel" 
                    getItemCount="setItemCount" 
                    getItemID="setItemId" 
                    getItemLabel="setItemLabel" 
                    getSelectedItemID="setItemDefault" 
                    getScreentip="setScreentip" 
                    onAction="selectPrinter" 
                    sizeString="wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww" 
                    getItemImage="setItemImage" 
                    imageMso="FilePrint" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

USysRibbons

'----Microsoft Office Object library 12.0----
Public Sub OnSelectLink(ctr As IRibbonControl)
    FollowHyperlink ctr.Tag
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <commands>
    <command idMso="ApplicationOptionsDialog" enabled="false" />
    <command idMso="FileExit" enabled="false" />
  </commands>
  <ribbon startFromScratch="true">
    <officeMenu>
      <button idMso="FileNewDatabase" visible="false" />
      <button idMso="FileOpenDatabase" visible="false" />
      <button idMso="FileCloseDatabase" visible="false" />
      <splitButton idMso="FileSaveAsMenuAccess" visible="false" />
      <menu id="linkmenu" label="Links" imageMso="HyperlinkInsert">
        <menuSeparator id="Sep1" title="検索" />
        <button id="btn01" label="グーグル" tag="http://www.google.co.jp" onAction="OnSelectLink" />
        <button id="btn02" label="グーグルMap" tag="http://maps.google.co.jp/maps" onAction="OnSelectLink" />
        <button id="btn03" label="ドラぷら高速料金検索" tag="http://www.driveplaza.com/dp/SearchQuick" onAction="OnSelectLink" />
        <button id="btn04" label="道路情報" tag="http://www.drivetraffic.jp/map.html" onAction="OnSelectLink" />
        <button id="btn05" label="道路情報" tag="http://www.jartic.or.jp" onAction="OnSelectLink" />
      </menu>
    </officeMenu>
  </ribbon>
</customUI>

要素<comannd>でAceessのオプション(ApplicationOptionsDialog)と Accessの終了(FileExit)を使用不可にすると、Officeメニューの各コマンドボタンは非活性化になる。また、要素<officeMenu>内<button>を不可視とすることが可能。
カスタムメニューとボタンを追加、OnActionでコールバック呼出し。

Access2007 アプリケーション終了のこと

意図しない方法でのアプリケーション終了

1. アプリケーション閉じるボタン押下
2. Alt+F4押下
3. officeボタン→閉じる押下

1は APIとかでボタンを非活性に2.はキーイベントなどでハンドリングで対応できたんだけど、3だけ対応できてなかった。よーく考えてみたらフォームのUnloadイベントで対応すればよかった。
--MainForm--

Option Compare Database
Option Explicit

Private Flg as Boolean

Private Sub Form_Unload(Cancel As Integer)
    Cancel = Not Flg
End Sub 

Private Sub btnApplicationQuit_Click()
    Flg = True
    Application.Quit
End Sub

Alt+F4/アプリケーション閉じるボタン押下/タスクバーで閉じるのいずれにも対応できる。オープンされている別のフォームにも影響できて閉じることはなかった。プロセスの終了かQuit押下以外に終了できなくなる。

Access2007 オプション設定-カレントデータベース

アプリケーションオプション
・ステータスバーを表示する
左下のステータスバーを表示するかどうかそのままの意味。
すっきりさせたいなら消す
・ドキュメントウインドウオプション
ウインドウを重ねて表示する
2003以前で使用していたウインドウ表示のイメージ
・タブ付きドキュメント
2007からデフォルトになってるからこれ使っておけばよいと思う
常に最大表示のウインドウということ。モーダルで開けばウインドウ切り替えが当然にできない。
タブ付きであっても同様
・ショートカットキーを有効にする
F11/Alt+F11/Ctrl+Gが無効化され、デバッグモードに移行しなくなる
・閉じるときに最適化
テンポラリのテーブルとかあるなら設定しておけばいいじゃないか

リボンとツールバーのオプション
・すべてのメニューを表示する
officeボタンに展開されるメニューとAccessのオプションボタンの設定
ただし、officeボタン右クリックからAccessのオプション設定に遷移できる
アドインは設定されない模様
・既定のショートカットメニュー
カスタムショートカットメニュー以外表示されなくなる

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

ショートカットキー抑制

Autokeysマクロで概ねカバーできるが、Alt+のショートカットが漏れる。
なので、フォームキーイベントでの代替案。

Option Compare Database
Option Explicit

Private WithEvents pFrm As Access.Form

Public Sub BindForm(Frm As Access.Form)
 Set pFrm = Frm
 pFrm.NavigationButtons = False 'ナビゲーションボタン
 pFrm.RecordSelectors = False  'レコードセレクタ
 pFrm.KeyPreview = True  'キーボードイベント取得
 pFrm.OnKeyDown = "[EVENT PROCEDURE]"
End Sub

Private Sub pFrm_KeyDown(KeyCode As Integer, Shift As Integer)
 Select Case Shift
  Case 0 'なし
  Case 1 'shift(16)
  Case 2 'Ctrl(17)
  Case 3 'shift+alt
  Case 4 'alt(18) alt+F4終了,alt+F11 VBE
   If KeyCode = vbKeyF4 Or KeyCode = vbKeyF11 Then KeyCode = 0
  Case 5 'shift+alt
  Case 6 'Ctrl+alt
  Case 7 'shift+Ctrl+alt
 End Select
End Sub

アプリケーション配布時の設定 MS-Access改

1.配布予定のaccdbをコピーし、以降の作業はこれを使う。＜重要＞

2.Autoexecマクロの設定
・コマンドの実行：最大化(アプリケーション)
・フォームを開く：mainmenu, フォーム ビュー, , , , 標準

3.Autokeysの設定
・｛F11｝：（アクションなし）（引数なし）---- ナビゲーションウインドウの表示
AutokeysではAlt組み合わせのショートカットキーを管理できないので、フォームイベントでハンドリングするしかない。

4.USysRibbonsテーブル作成
ID：オートナンバー型　　RibbonName：テキスト型　　RibbonXml：メモ型
----------Record　1
HideRibbon
＜customui xmlns="http://schemas.microsoft.com/office/2006/01/customui">
＜ribbon startFromScratch="true">
＜/ribbon>
＜/customUI>
----------Record　2
ShowRibbon
＜customui xmlns="http://schemas.microsoft.com/office/2006/01/customui">
＜ribbon startFromScratch="false">
＜/ribbon>
＜/customUI>

5.Accessのオプション→カレントデータベース
アプリケーションオプション
・ドキュメントタブを表示する：チェック外す
・閉じるときに最適化する：チェックする
・ショートカットキーを有効にする：チェック外す
・このデータベースのレイアウトビューを使用可能にする：チェック外す
・データシートビューでテーブルデザインを変更可能にする：チェック外す
ナビゲーション
・ナビゲーションウインドウを表示する：チェック外す
・ナビゲーションオプション：すべてチェックを外す
リボンとツールバーのオプション
・リボン名：HideRibbon
・すべてのメニューを表示する：チェック外す
・既定のショートカットメニュー：チェック外す

アプリケーションオプションのショートカットキーを有効にするのチェックを外すと、
F11（ナビゲーションウインドウの表示）
Alt+F11（VBEの表示）
Ctrl+G（イミディエイトウインドウの表示）
などが無効化される。リボンをカスタムリボンに置き換えることで、VBE表示を抑止できる。
ただし、
・エラー発生時デバッグモードに移行しない
・エラーメッセージが表示されない
・エラー発生したプロシージャはエラー発生時点で終了する
結果、予期しない作動が発生しうるから、エラーハンドリングを充分に行う必要がある
ランタイムモードもしくはランタイム環境の場合は、実行時エラーでアプリケーションは強制終了へ。

6.mainmenu(スタートアップフォーム)Open かLoad　イベント時（要検証）
DoCmd.LockNavigationPane True
多分、カスタムリボン設定のところでショートカットできなくなるから要らん気がする。

7.Bypasskey（Shift+起動）を抑制するプロシージャ起動
Public Sub UpdateAllowBypasskey()
Dim Dbs As Database
Dim Prp As Property
On Error GoTo ErrLabel
Set Dbs = CurrentDb
Dbs.Properties!AllowBypassKey = False 'Falseでバイパスを認めない
Exit Sub
ErrLabel:
If Err = 3270 Then
    Set Prp = Dbs.CreateProperty("AllowBypassKey", dbBoolean, True)
    Dbs.Properties.Append Prp
End If
End Sub

8.accdeへ変換 　

ユーザがランタイムのみであればさほど気にせずでよいが、製品を使用している場合、accde化してあればコード表示がされないが、そのままではナビゲーションウインドウの表示ができてしまうから、直接テーブルの操作、予期しないフォーム・クエリの実行ができる。

これでいけるか？

アプリケーション配布時の設定 MS-Access

アプリケーション配布にあたり、検討しておくべき事項。ユーザの環境に依存すること。
方法1.パッケージソリューションウィザードを使用し、ファイル配布ではなくアプリケーション配布今のところお手軽かつ確実っぽい。スタートアップ時の設定(Autoexec)とAutokeysマクロは当然として、ナビゲーションウインドウ非表示、リボン非表示など網羅できる。
だが、インストール先のファイル名を操作することでいじれちゃう可能性あり

方法2.ファイル配布
こっちはいろいろ手順を踏む必要あり

• スタートアップ時の設定 

これについては、Autoexecマクロを使った方が便利。定型っぽい感じで使えてインポートできるから。
・ コマンドの実行：最大化（アプリケーション）
・フォームを開く："最初に開くフォーム",フォーム ビュー, , , , 標準
等など

• Autokeysマクロ

 AccessなどOffice特有のショートカットキーを抑制する
＾｛F6｝：フォーム間移動抑制　＾+｛F6｝：フォーム間移動抑制　＾ｓとか＾ｐ
ただし、Altを含むキーストロークのハンドリングはKeyイベントで

• Shift（Bypasskey）の無効化

Public Sub UpdateAllowBypasskey()
Dim Dbs As Database
Dim Prp As Property

On Error GoTo ErrLabel
Set Dbs = CurrentDb
Dbs.Properties!AllowBypassKey = False
Exit Sub
ErrLabel:
If Err = 3270 Then
    Set Prp = Dbs.CreateProperty("AllowBypassKey", dbBoolean, True)
    Dbs.Properties.Append Prp
End If
End Sub

スタートアップフォームLoadイベントで実行

accdeに変換してでユーザがRuntime環境であれば概ねこのくらいでも可。
ただ、ユーザがAccessを使用している場合、少々問題がある
リボン表示はUIカスタマイズで<ribbon startFromScratch="false">のUｓSysRibbonsテーブルを用意しリボン自体をカスタマイズとか。
ナビゲーションウィンドウが操作できちゃったりするのでその対策、 
DoCmd.LockNavigationPane True などが必要

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