Office 2007/2010・リボンのカスタマイズ 初心者備忘録

カスタム検索
Office関連

開いているデータベースを最適化する(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」ファイルを参照する必要があります。