大分前の記事になりますが、開いているデータベースを最適化するマクロのコードを下記ページで公開しています。

www.ka-net.org

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

http://www.ka-net.org/office/of05.html

www.ka-net.org

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

http://www.ka-net.org/office/of06.html

www.ka-net.org

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

http://www.ka-net.org/office/of18.html

気が向いたので、今回改めてデータベースの最適化と修復を行うマクロを書いてみることにしました。

'UIAutomationClient(UIAutomationCore.dll)要参照
Option Explicit

Public Sub Sample()
  CompactAndRepairDatabase "C:\Test\TestDB.accdb"
End Sub

Private Sub CompactAndRepairDatabase(ByVal DBPath As String)
'[データベースの最適化/修復]を実行
  Dim uiAuto As CUIAutomation
  Dim accRibbon As IAccessible
  Dim elmRibbon As IUIAutomationElement
  Dim elmRibbonTab As IUIAutomationElement
  Dim elmDBRepairButton As IUIAutomationElement
  Dim ptnSel As IUIAutomationSelectionItemPattern
  Dim ptnInvoke As IUIAutomationInvokePattern
  
  Set uiAuto = New UIAutomationClient.CUIAutomation
  With CreateObject("Access.Application")
    .Visible = True
    .OpenCurrentDatabase DBPath
    
    '[データベース ツール]タブ選択
    Set accRibbon = .CommandBars("Ribbon")
    Set elmRibbon = uiAuto.ElementFromIAccessible(accRibbon, 0)
    Set elmRibbonTab = GetElement(uiAuto, _
                                  elmRibbon, _
                                  UIA_NamePropertyId, _
                                  "データベース ツール", _
                                  UIA_TabItemControlTypeId)
    If elmRibbonTab Is Nothing Then GoTo Fin
    Set ptnSel = elmRibbonTab.GetCurrentPattern(UIA_SelectionItemPatternId)
    ptnSel.Select
    
    '[データベースの最適化/修復]ボタンクリック
    Set elmDBRepairButton = GetElement(uiAuto, _
                                       elmRibbon, _
                                       UIA_NamePropertyId, _
                                       "データベースの最適化/修復", _
                                       UIA_ButtonControlTypeId)
    If elmDBRepairButton Is Nothing Then GoTo Fin
    Set ptnInvoke = elmDBRepairButton.GetCurrentPattern(UIA_InvokePatternId)
    ptnInvoke.Invoke
Fin:
    .CloseCurrentDatabase
    .Quit
  End With
End Sub

Private Function GetElement(ByVal uiAuto As CUIAutomation, _
                            ByVal elmParent As IUIAutomationElement, _
                            ByVal propertyId As Long, _
                            ByVal propertyValue As Variant, _
                            Optional ByVal ctrlType As Long = 0) As IUIAutomationElement
  Dim cndFirst As IUIAutomationCondition
  Dim cndSecond As IUIAutomationCondition
     
  Set cndFirst = uiAuto.CreatePropertyCondition( _
                   propertyId, _
                   propertyValue _
                 )
  If ctrlType <> 0 Then
    Set cndSecond = uiAuto.CreatePropertyCondition( _
                      UIA_ControlTypePropertyId, _
                      ctrlType _
                    )
    Set cndFirst = uiAuto.CreateAndCondition( _
                     cndFirst, _
                     cndSecond _
                   )
  End If
  Set GetElement = elmParent.FindFirst(TreeScope_Subtree, cndFirst)
End Function

仕組みとしては、UI Automationを使って、

[データベース ツールタブ]を選択
↓
[データベースの最適化/修復]ボタンをクリック

といった操作を行うもので、Access上で開いているデータベース自身を最適化するのではなく、外部(Excel等)から複数のファイルを連続して最適化することを目的としています。

需要があるかどうかは分かりませんが、どなたかのご参考になれば幸いです。
ちなみに、タブやボタンの配置、名前に依存したコードですので、今後のAccessのバージョンアップによっては動作しなくなる可能性がある点についてはご注意ください。

オマケ

今回のコードを書くにあたり、ExecuteMsoメソッドを使って開いているデータベースの最適化ができるかどうかのテストもしてみました。

Private Sub Test()
  Application.CommandBars.ExecuteMso "FileCompactAndRepairDatabase"
End Sub

案の定実行できなかったのですが、表示されたメッセージが下図です。

マクロまたは Visual Basic コードを実行して、開いているデータベースを最適化することはできません。

マクロまたはコードを使用する代わりに、[ファイル] タブをクリックし、[データベースの最適化/修復] をクリックしてください。

といったメッセージが表示されているはずなのですが、文字が重なっているので全然読めませんね😅

仕様というか、バグというか、何れにせよあまり見る機会は無さそうなメッセージボックスです。気が向いたらMicrosoftにフィードバックしておきます。

2019/8/15 追記：
Tech Communityでフィードバック後、気が付いたら問題のメッセージは修正されていました。

2019.08.15

Office製品のフィードバックって本当に反映されるの？

今年の1月に、WordやExcel等のOffice製品で、UI上の不具合や改善点を見つけたときは「Tech Community」でフィードバックできる、といった内容の記事を書きました。 ただ、「このサイトに投稿しても本当に製品に反映されるの？」、...