access2010 access2007 更新前処理イベント内で閉じるボタンのクリックを判定する方法

YU-TANGさんところの
更新前処理イベント内で閉じるボタンのクリックを判定する方法
をaccess2010でやってみた。
タブ付きドキュメントである場合の件。とりあえず動作することは確認できた。

Option Compare Database
Option Explicit

'*************************
'参照設定
'oleacc.dll
'*************************

Const ROLE_SYSTEM_LIST = &H21
Const ROLE_SYSTEM_PUSHBUTTON = &H2B
Const ROLE_SYSTEM_BUTTONMENU = &H39
Const ROLE_SYSTEM_PROPERTYPAGE = &H26
Const ROLE_SYSTEM_MENUITEM = &HC
Const ROLE_SYSTEM_CLIENT = &HA

Private IsRibbonAction As Boolean

Type POINTAPI
        X As Long
        Y As Long
End Type
 
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
                                 
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
                                lpPoint As POINTAPI _
                                ) As Long
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal llXY As LongLong, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
 
Private Function PointToLongLong(point As POINTAPI) As LongLong
    Dim ll As LongLong, cbLongLong As LongPtr
    cbLongLong = LenB(ll)
    If LenB(point) = cbLongLong Then
        CopyMemory ll, point, cbLongLong
    End If
    PointToLongLong = ll
End Function
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal xScreen As Long, _
                                ByVal yScreen As Long, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
#End If
#Else
Private Declare Function GetCursorPos Lib "user32" ( _
                                lpPoint As POINTAPI _
                                ) As Long
 
Private Declare Function AccessibleObjectFromPoint Lib "oleacc" ( _
                                ByVal xScreen As Long, _
                                ByVal yScreen As Long, _
                                ByRef ppvObject As Any, _
                                ByRef pvarChild As Variant _
                                ) As Long
#End If
 
Function IsCloseButtonClicked() As Boolean
    Dim xy As POINTAPI, acc As IAccessible
    Dim Child As Variant, btnName As String, tabCaption As String
    
    If IsRibbonAction Then
        IsCloseButtonClicked = True
        IsRibbonAction = False
        Exit Function
    End If
    
    GetCursorPos xy
 
#If Win64 Then
    AccessibleObjectFromPoint PointToLongLong(xy), acc, Child
#Else
    AccessibleObjectFromPoint xy.X, xy.Y, acc, Child
#End If
 
    If acc Is Nothing Then
        IsCloseButtonClicked = False
        Exit Function
    End If
 
    btnName = acc.accName(Child)
 
    tabCaption = CodeContextObject.Caption
    If tabCaption = "" Then
        tabCaption = CodeContextObject.Name
    End If

    Select Case acc.accRole(Child)
        Case ROLE_SYSTEM_LIST
            MsgBox "タスクバー:すべてのウィンドウを閉じる" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_PUSHBUTTON
            If InStr(1, btnName, "を閉じる") > 1 Then
                MsgBox "フォーム閉じるボタン" & _
                        vbCrLf & btnName
            Else
                MsgBox "Application閉じるボタン" & _
                        vbCrLf & btnName
            End If
        Case ROLE_SYSTEM_BUTTONMENU
            MsgBox "システムメニュー:閉じる" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_MENUITEM
            MsgBox "フォームアイコンダブルクリック" & _
                    vbCrLf & btnName
        Case ROLE_SYSTEM_PROPERTYPAGE
            '結果的にこうなる
            MsgBox "Applicationアイコンダブルクリック" & _
                    vbCrLf & btnName
        Case Else
            MsgBox "不明 もしくは、Backstageのコマンド" & _
                    vbCrLf & btnName
    End Select
    IsCloseButtonClicked = True
End Function

'RibbonXmlで検知:フォームが開いていること前提
Sub onActionClose(ctr As Object, CancelDefault)
    If Screen.ActiveForm.Dirty Then
        MsgBox "RibbonXmlで管理できるコマンド:" & ctr.ID
        IsRibbonAction = True
    End If
    CancelDefault = False
End Sub

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <commands>
    <command idMso="WindowClose" onAction="onActionClose" />
    <command idMso="CloseDocument" onAction="onActionClose" />
    <command idMso="FileCloseDatabase" onAction="onActionClose" />
    <command idMso="FileExit" onAction="onActionClose" />
  </commands>
</customUI> 

a2007でも動作するけどOfficeメニューから閉じる動作については対応は今のところ放置。同様に、BackStageから閉じる場合も反応できない。この辺はリボンカスタマイズでなんとかなるかな。タスクバーから閉じる場合もダメなんす。 a2010Runtimeだけシステムメニューから閉じるの場合反応なし。a2010（x64）についてはからっきし動作しない。調査してみるけど、これは俺には無理かも。AccessibleObjectFromPoint にXYをどのように渡すかだろうか。

64bitも動作するようになった。座標をLongLongで渡して成功。そして、デレクティブ。
でも、考えないといけないこと、たくさんあるな。どうしようかな。いずれにせよ、とりあえず。

いろいろ継ぎはぎしてみてBackstageとかOfficemenuもRibbonXmlで一応握ってみたと。
んー、やっぱりとりあえずレベル。たまに失敗している気配はしている。検証甘いから、何も考えずに実装するするにはちょっと心もとない。Accessibleを使うっつーところだけがポイントだろうか。