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

※ この情報はOffice 2010 Public Beta版を元にしています。製品版では変更になる可能性がありますのでご注意ください。

下記「CompactAndRepairDatabase」プロシージャを実行することで、現在開いているデータベース自身を最適化できます。
※ 入力中のデータが失われる場合がありますので、下記コードを実行する際は十分ご注意ください。


                    Option Explicit

                    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 AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, riid As Any, ByRef ppvObject As IAccessible) As Long

                    Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long

                    

                    Private Const CHILDID_SELF = 0&

                    Private Const OBJID_CLIENT = &HFFFFFFFC

                    Private Const ROLE_SYSTEM_PANE = &H10

                    Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B

                    

                    Public Sub CompactAndRepairDatabase()

                      Dim accApp As IAccessible

                      Dim accBackstage As IAccessible

                      Dim accBtnCompactAndRepair As IAccessible

                      Dim accBtnFile As IAccessible

                      Dim accRibbon As IAccessible

                      Dim IID(0 To 3) As Long

                      

                      Set accRibbon = Application.CommandBars("Ribbon")

                      Set accBtnFile = GetAcc(accRibbon, "ファイル タブ", ROLE_SYSTEM_PUSHBUTTON)

                      If accBtnFile Is Nothing Then Exit Sub

                      Call accBtnFile.accDoDefaultAction(CHILDID_SELF) 'ファイルタブボタンクリック

                      DoEvents

                      

                      Call IIDFromString(StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), IID(0))

                      If AccessibleObjectFromWindow(Application.hWndAccessApp, OBJID_CLIENT, IID(0), accApp) <> 0& Then Exit Sub

                      Set accBackstage = GetAcc(accApp, "Backstage ビュー", ROLE_SYSTEM_PANE) 'Backstage

                      If accBackstage Is Nothing Then Exit Sub

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

                      If accBtnCompactAndRepair Is Nothing Then Exit Sub

                      Call accBtnCompactAndRepair.accDoDefaultAction(CHILDID_SELF) 'データベースの最適化/修復ボタンクリック

                    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

※ 上記コードを実行する前に「system32」フォルダ内の「oleacc.dll」ファイルを参照する必要があります。