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

カスタム検索
Office関連

開いているデータベースを最適化する(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」プロシージャから、データベースの最適化を実行することができます。