開いているデータベースを最適化する(Access 2007 VBA)

「開いているデータベースを最適化する(Access VBA)」で、データベースを最適化するコードを紹介しましたが、Access 2007で実行すると下記のようなメッセージが表示され、実行することができません。

下記のコードでも同様にエラーメッセージが表示されて実行することができませんでした。


                    Sub Test01()

                      Application.DoCmd.RunCommand (acCmdCompactDatabase)

                    End Sub

                    

                    Sub Test02()

                      Application.CommandBars.ExecuteMso ("FileCompactAndRepairDatabase")

                    End Sub

                    

                    Sub Test03()

                      Application.CommandBars.FindControl(id:=2071).accDoDefaultAction

                    End Sub

                    

                    Sub Test04()

                      Application.CommandBars.FindControl(id:=2071).Execute

                    End Sub

Access 2007ではどうやらVBAからの最適化実行はできなくなってしまったようです。
そこで今回はIAccessibleオブジェクトを利用して、無理やり最適化を実行するコードを紹介します。
3通りの方法をここでは紹介しますが、クイックアクセスツールバーやカスタマイズしたリボンを使用しない「Officeメニューから自DBを最適化する」方法が一番簡単です。

クイックアクセスツールバーから自DBを最適化する

1. 「クイックアクセスツールバーのカスタマイズ」ボタンから「その他のコマンド」を開きます。

2. 「クイックアクセスツールバーのカスタマイズ」は、「(ドキュメント名)に適用」を選択します(「すべてのドキュメントに適用」でも問題ありません)。
「コマンドの選択」から「Office メニュー」を選択し、「最適化/修復」を追加後、「OK」ボタンをクリックします。

3. クイックアクセスツールバーに「データベースの最適化/修復」が追加されていることが確認できます。

4. 「作成」タブの「マクロ」から「標準モジュール」を選択し、標準モジュールを追加します。

5. VBE画面の「ツール」メニューから「参照設定」を開きます。

6. 参照設定ダイアログから「参照」ボタンをクリックします。

7. ファイルの参照ダイアログが表示されるので、System32フォルダから「oleacc.dll」ファイルを選択し、「開く」ボタンをクリックします。

8. 再び参照設定ダイアログが表示されるので、「Accessibility」にチェックが入っていることを確認して「OK」ボタンをクリックします。

9. 標準モジュールに下記コードを貼り付け、標準モジュールを保存します。


                        Option Compare Database

                        

                        Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long

                        

                        Private Const CHILDID_SELF = 0&

                        Private Const NAVDIR_FIRSTCHILD = &H7

                        

                        'accRole

                        Private Const ROLE_SYSTEM_PROPERTYPAGE = &H26   'リボン , タブ , ステータス バー

                        Private Const ROLE_SYSTEM_TOOLBAR = &H16  'クイック アクセス ツール バー , グループ

                        Private Const ROLE_SYSTEM_PAGETABLIST = &H3C  'リボン タブ

                        Private Const ROLE_SYSTEM_PANE = &H10   '下リボン

                        Private Const ROLE_SYSTEM_GROUPING = &H14   'コンテキスト タブのヘッダー

                        Private Const ROLE_SYSTEM_PAGETAB = &H25  'コンテキスト タブ(書式等)

                        Private Const ROLE_SYSTEM_BUTTONDROPDOWNGRID = &H3A   'Microsoft Office ボタン

                        Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B   'ボタン

                        

                        Sub CompactAndRepairDatabase_QAT()

                        'クイックアクセスツールバーから自DBを最適化するプロシージャ

                        

                          Dim myAcc As IAccessible

                          

                          On Error GoTo myErr

                          

                          '"データベースの最適化/修復"ボタンクリック

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "クイック アクセス ツール バー", ROLE_SYSTEM_TOOLBAR)

                          Set myAcc = GetAcc(myAcc, "データベースの最適化/修復", ROLE_SYSTEM_PUSHBUTTON)

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          Set myAcc = Nothing

                          Exit Sub

                        

                        myErr:

                          MsgBox "実行時エラー:" & Err.Number & vbCrLf & Err.Description, _

                                 vbCritical, "処理が失敗しました。"

                        End Sub

                        

                        Private Function GetAcc(myAcc As IAccessible, myAccName As String, myAccRole As Long) As IAccessible

                          Dim ReturnAcc As IAccessible

                          Dim ChildAcc As IAccessible

                          Dim List() As Variant

                          Dim Count As Long

                          Dim i As Long

                          

                          If (myAcc.accState(CHILDID_SELF) <> 32769) And _

                             (myAcc.accName(CHILDID_SELF) = myAccName) And _

                             (myAcc.accRole(CHILDID_SELF) = myAccRole) Then

                            Set ReturnAcc = myAcc

                          Else

                            Count = myAcc.accChildCount

                            

                            If Count > 0& Then

                              ReDim List(Count - 1&)

                              If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then

                                For i = LBound(List) To UBound(List)

                                  If TypeOf List(i) Is IAccessible Then

                                    Set ChildAcc = List(i)

                                    Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)

                                    If Not ReturnAcc Is Nothing Then Exit For

                                  End If

                                Next

                              End If

                            End If

                            

                          End If

                          

                          Set GetAcc = ReturnAcc

                        End Function

以上で作業は終了です。
以降「CompactAndRepairDatabase_QAT」プロシージャから、データベースの最適化を実行することができます。

カスタマイズしたリボンから自DBを最適化する

1. 「USysRibbons」テーブルの「RibbonXml」フィールドに下記コードを貼り付け、上書き保存します。


                        <customUI onLoad="Ribbon_onLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">

                          <ribbon>

                            <tabs>

                              <tab id="myTab" label="最適化" getVisible="myTab_getVisible">

                                <group id="myGroup" label="My Group">

                                  <button idMso="FileCompactAndRepairDatabase" size="large" />

                                </group>

                              </tab>

                            </tabs>

                          </ribbon>

                        </customUI>

※ RibbonNameフィールドには任意のリボン名を入力しておいてください。

2. 上記「クイックアクセスツールバーから自DBを最適化する」の4. - 8.の処理を参考に「標準モジュール」を追加した後、「Accessibility」と「Microsoft Office 12.0 Object Library」を参照します。

3. 標準モジュールに下記コードを貼り付け、標準モジュールを保存します。


                        Option Compare Database

                        

                        Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long

                        

                        Private Const CHILDID_SELF = 0&

                        Private Const NAVDIR_FIRSTCHILD = &H7

                        

                        'accRole

                        Private Const ROLE_SYSTEM_PROPERTYPAGE = &H26  'リボン , タブ , ステータス バー

                        Private Const ROLE_SYSTEM_TOOLBAR = &H16  'クイック アクセス ツール バー , グループ

                        Private Const ROLE_SYSTEM_PAGETABLIST = &H3C  'リボン タブ

                        Private Const ROLE_SYSTEM_PANE = &H10  '下リボン

                        Private Const ROLE_SYSTEM_GROUPING = &H14  'コンテキスト タブのヘッダー

                        Private Const ROLE_SYSTEM_PAGETAB = &H25  'コンテキスト タブ(書式等)

                        Private Const ROLE_SYSTEM_BUTTONDROPDOWNGRID = &H3A  'Microsoft Office ボタン

                        Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B  'ボタン

                        

                        Private myRibbon As IRibbonUI

                        Private myTabVisible As Boolean

                        

                        Sub Ribbon_onLoad(ribbon As IRibbonUI)

                          Set myRibbon = ribbon

                          myTabVisible = False

                        End Sub

                        

                        Sub myTab_getVisible(control As IRibbonControl, ByRef visible)

                          visible = myTabVisible

                        End Sub

                        

                        Sub ChangeVisibleMyTab()

                        'タブの表示設定用

                          myTabVisible = True

                          Call myRibbon.InvalidateControl("myTab")

                        End Sub

                        

                        Sub CompactAndRepairDatabase_Ribbon()

                        '"最適化"タブの"データベースの最適化/修復"ボタンから

                        '自DBを最適化するプロシージャ

                        

                          Dim myAcc As IAccessible

                          

                          Application.Echo False    '画面描画停止

                          

                          Call ChangeVisibleMyTab   '"最適化"タブ表示

                          DoEvents    'IAccessibleアクセス待ち

                          

                          On Error GoTo myErr

                          

                          '"最適化"タブに切替

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)

                          Set myAcc = GetAcc(myAcc, "最適化", ROLE_SYSTEM_PAGETAB)   'この"最適化"はRibbonXmlのタブのlabel属性の値

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          DoEvents    'IAccessibleアクセス待ち

                          

                          '"データベースの最適化/修復"ボタンクリック

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "下リボン", ROLE_SYSTEM_PANE)

                          Set myAcc = GetAcc(myAcc, "データベースの最適化/修復", ROLE_SYSTEM_PUSHBUTTON)

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          

                          Set myAcc = Nothing

                          Application.Echo True

                          

                          Exit Sub

                        

                        myErr:

                          MsgBox "実行時エラー:" & Err.Number & vbCrLf & Err.Description, _

                                 vbCritical, "処理が失敗しました。"

                        End Sub

                        

                        Private Function GetAcc(myAcc As IAccessible, myAccName As String, myAccRole As Long) As IAccessible

                          Dim ReturnAcc As IAccessible

                          Dim ChildAcc As IAccessible

                          Dim List() As Variant

                          Dim Count As Long

                          Dim i As Long

                          

                          If (myAcc.accState(CHILDID_SELF) <> 32769) And _

                             (myAcc.accName(CHILDID_SELF) = myAccName) And _

                             (myAcc.accRole(CHILDID_SELF) = myAccRole) Then

                            Set ReturnAcc = myAcc

                          Else

                            Count = myAcc.accChildCount

                            

                            If Count > 0& Then

                              ReDim List(Count - 1&)

                              If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then

                                For i = LBound(List) To UBound(List)

                                  If TypeOf List(i) Is IAccessible Then

                                    Set ChildAcc = List(i)

                                    Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)

                                    If Not ReturnAcc Is Nothing Then Exit For

                                  End If

                                Next

                              End If

                            End If

                            

                          End If

                          

                          Set GetAcc = ReturnAcc

                        End Function

4. 一度データベースを閉じ、再度データベースを開いた後「Accessのオプション」を開きます。
5. 「カレントデータベース」の「リボン名」プルダウンから、1.で入力したリボン名を選択し、「OK」ボタンをクリックします。

6. 確認のダイアログが表示されるので、「OK」ボタンをクリックします。

7. 一度データベースを閉じ再度データベースを開きます。

以上で作業は終了です。
以降「CompactAndRepairDatabase_Ribbon」プロシージャから、データベースの最適化を実行することができます。なお、最適化処理前に「Application.Echo False」を入れていますので、データベースを扱うユーザには処理中のタブの切替動作は見えません。
また、Accessのリボンのカスタマイズ方法の詳細については、「リボンをカスタマイズする(Access)」を参照してください。

Officeメニューから自DBを最適化する

1. 上記「クイックアクセスツールバーから自DBを最適化する」の4. - 8.の処理を参考に「標準モジュール」を追加した後、「Accessibility」を参照します。
2. 標準モジュールに下記コードを貼り付け、標準モジュールを保存します。


                        Option Compare Database

                        

                        Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long

                        Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long

                        Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

                        

                        Private Const CHILDID_SELF = 0&

                        Private Const NAVDIR_FIRSTCHILD = &H7

                        

                        'accRole

                        Private Const ROLE_SYSTEM_PROPERTYPAGE = &H26  'リボン , タブ , ステータス バー

                        Private Const ROLE_SYSTEM_TOOLBAR = &H16  'クイック アクセス ツール バー , グループ

                        Private Const ROLE_SYSTEM_PAGETABLIST = &H3C  'リボン タブ

                        Private Const ROLE_SYSTEM_PANE = &H10  '下リボン

                        Private Const ROLE_SYSTEM_GROUPING = &H14  'コンテキスト タブのヘッダー

                        Private Const ROLE_SYSTEM_PAGETAB = &H25  'コンテキスト タブ(書式等)

                        Private Const ROLE_SYSTEM_BUTTONDROPDOWNGRID = &H3A  'Microsoft Office ボタン

                        Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B  'ボタン

                        Private Const ROLE_SYSTEM_MENUITEM = &HC   'メニュー

                        

                        Sub CompactAndRepairDatabase()

                        'Officeメニューの"データベースの最適化/修復"から

                        '自DBを最適化するプロシージャ

                        

                          Dim myAcc As IAccessible

                          

                          On Error GoTo myErr

                          Call LockWindowUpdate(GetDesktopWindow())    '画面描画停止

                          

                          'Officeボタンクリック

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "Office ボタン", ROLE_SYSTEM_BUTTONDROPDOWNGRID)

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          DoEvents    'IAccessibleアクセス待ち

                          

                          '"管理"メニュークリック

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "管理", ROLE_SYSTEM_MENUITEM)

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          DoEvents    'IAccessibleアクセス待ち

                          

                          '"データベースの最適化/修復"メニュークリック

                          Set myAcc = Application.CommandBars("Ribbon")

                          Set myAcc = GetAcc(myAcc, "データベースの最適化/修復", ROLE_SYSTEM_MENUITEM)

                          myAcc.accDoDefaultAction (CHILDID_SELF)

                          

                          Set myAcc = Nothing

                          Call LockWindowUpdate(0&)    '画面描画再開

                          Exit Sub

                        

                        myErr:

                          MsgBox "実行時エラー:" & Err.Number & vbCrLf & Err.Description, _

                                 vbCritical, "処理が失敗しました。"

                        End Sub

                        

                        Private Function GetAcc(myAcc As IAccessible, myAccName As String, myAccRole As Long) As IAccessible

                          Dim ReturnAcc As IAccessible

                          Dim ChildAcc As IAccessible

                          Dim List() As Variant

                          Dim Count As Long

                          Dim i As Long

                          

                          If (myAcc.accState(CHILDID_SELF) <> 32769) And _

                             (myAcc.accName(CHILDID_SELF) = myAccName) And _

                             (myAcc.accRole(CHILDID_SELF) = myAccRole) Then

                            Set ReturnAcc = myAcc

                          Else

                            Count = myAcc.accChildCount

                            

                            If Count > 0& Then

                              ReDim List(Count - 1&)

                              If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then

                                For i = LBound(List) To UBound(List)

                                  If TypeOf List(i) Is IAccessible Then

                                    Set ChildAcc = List(i)

                                    Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)

                                    If Not ReturnAcc Is Nothing Then Exit For

                                  End If

                                Next

                              End If

                            End If

                            

                          End If

                          

                          Set GetAcc = ReturnAcc

                        End Function

以上で作業は終了です。
以降「CompactAndRepairDatabase」プロシージャから、データベースの最適化を実行することができます。