access2010 access2007 メッセージバー（読み取り専用）の制御

Option Compare Database
Option Explicit
'*********************************************
'引用及び参考：http://www.ka-net.org/
'参照設定：oleacc.dll
'*********************************************
Private Const CHILDID_SELF = 0&
Private Const OBJID_CLIENT = &HFFFFFFFC
Private Const ROLE_SYSTEM_PUSHBUTTON = &H2B

#If VBA7 Then
Private Declare PtrSafe 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 PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
                                ByVal hWnd As LongPtr, _
                                ByVal dwId As Long, _
                                riid As Any, _
                                ByRef ppvObject As IAccessible _
                                ) As Long
 
Private Declare PtrSafe Function IIDFromString Lib "ole32" ( _
                                ByVal lpsz As LongPtr, _
                                lpiid As Any _
                                ) As Long

Private Declare PtrSafe Function FindWindowEx Lib "user32" _
                                Alias "FindWindowExA" ( _
                                ByVal hWnd1 As LongPtr, _
                                ByVal hWnd2 As LongPtr, _
                                ByVal lpsz1 As String, _
                                ByVal lpsz2 As String _
                                ) As LongPtr
Private Function MsgBarHwnd() As LongPtr
    Dim hndl As LongPtr
    hndl = FindWindowEx(hWndAccessApp, 0, _
                       "MsoCommandBarDock", "MsoDockTop")
    hndl = FindWindowEx(hndl, 0, "MsoCommandBar", " ") '決め打ちしてるところ
    hndl = FindWindowEx(hndl, 0, "MsoWorkPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NUIPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NetUIHWND", vbNullString)
    MsgBarHwnd = hndl
End Function
#Else
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 Declare Function FindWindowEx Lib "user32" _
                                Alias "FindWindowExA" ( _
                                ByVal hWnd1 As Long, _
                                ByVal hWnd2 As Long, _
                                ByVal lpsz1 As String, _
                                ByVal lpsz2 As String _
                                ) As Long

Private Function MsgBarHwnd() As Long
    Dim hndl As Long
    hndl = FindWindowEx(hWndAccessApp, 0, _
                       "MsoCommandBarDock", "MsoDockTop")
    hndl = FindWindowEx(hndl, 0, "MsoCommandBar", " ") '決め打ちしてるところ
    hndl = FindWindowEx(hndl, 0, "MsoWorkPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NUIPane", vbNullString)
    hndl = FindWindowEx(hndl, 0, "NetUIHWND", vbNullString)
    MsgBarHwnd = hndl
End Function
#End If
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

Function MsgBarClose()
    If CurrentDb.Updatable Then Exit Function
    Do Until MsgBarHwnd <> 0
        DoEvents
    Loop
    Dim accApp As IAccessible, acc As IAccessible, accChild As IAccessible
    Dim IID(0 To 3) As Long, strName As String
#If VBA7 Then
    strName = "このメッセージを閉じる"
#Else
    strName = "閉じる"
#End If
    IIDFromString StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), IID(0)
    If AccessibleObjectFromWindow(MsgBarHwnd, _
                                  OBJID_CLIENT, _
                                  IID(0), _
                                  acc) _
                                  <> 0 Then Exit Function

    Set accChild = GetAcc(acc, strName, ROLE_SYSTEM_PUSHBUTTON)
    accChild.accDoDefaultAction CHILDID_SELF
End Function

ちょっと安定した
振り返ると、メッセージバーを表示しないメニューコマンドの実行/DoCmd.RunCommand acCmdHideMessageBar で制御できるし。