Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
Private Const CHILDID_SELF = 0&
' 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 SelRibbonTAB(myTabName As String)
  Rem 指定リボンタブ選択処理
  Dim myAcc As Office.IAccessible
  On Error GoTo myErr
  Set myAcc = Application.CommandBars("Ribbon")
  Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
  Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
  myAcc.accDoDefaultAction (CHILDID_SELF)
  Set myAcc = Nothing
  Exit Sub
  Exit Sub
  MsgBox "実行時エラー:" & Err.Number & vbCrLf & Err.Description, _
         vbCritical, "処理が失敗しました。"
End Sub

Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
  Dim ReturnAcc As Office.IAccessible
  Dim ChildAcc As Office.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
    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 Office.IAccessible Then
            Set ChildAcc = List(i)
            Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
            If Not ReturnAcc Is Nothing Then Exit For
          End If
      End If
    End If
  End If
  Set GetAcc = ReturnAcc
End Function

inserted by FC2 system