基本的にフォームだけなのだけど、PopUpの時もしくはカスケード表示の時のフォーム上のシステムメニュー(っていうでしたっけ、フォームアイコン右クリメニュー)は検知できていない。
以下コードは64bit用。
Option Compare Database Option Explicit Public Const ROLE_SYSTEM_LIST = &H21 Public Const ROLE_SYSTEM_PUSHBUTTON = &H2B Public Const ROLE_SYSTEM_BUTTONMENU = &H39 Public Const ROLE_SYSTEM_PROPERTYPAGE = &H26 Public Const ROLE_SYSTEM_MENUITEM = &HC '************************* '参照設定 'olcacc.dll '検証環境 'Win7(64)+Access2010(x64) '************************* Type POINTAPI X As Long Y As Long End Type Declare PtrSafe Function GetCursorPos Lib "user32" ( _ lpPoint As POINTAPI _ ) As Long Declare PtrSafe Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" ( _ Destination As Any, _ Source As Any, _ ByVal Length As LongPtr) Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" ( _ ByVal llXY As LongLong, _ ByRef ppvObject As Any, _ ByRef pvarChild As Variant _ ) As Long 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 'RibbonXmlで検知 Sub onActionWindowClose(ctr As Object, CancelDefault As Boolean) 'タブ表示でなくフォームが最大化されている時 MsgBox "閉じるコマンド:WindowClose" End Sub Sub onActionCloseDocument(ctr As Object, CancelDefault As Boolean) MsgBox "閉じるコマンド:CloseDocument" End Sub Sub onActionFileCloseDatabase(ctr As Object, CancelDefault As Boolean) MsgBox "データベースを閉じるコマンド:FileCloseDatabase" End Sub Sub onActionFileExit(ctr As Object, CancelDefault As Boolean) MsgBox "終了コマンド:FileExit" End Sub
Option Compare Database Option Explicit Private CloseCancel As Boolean Private Sub Form_Load() CloseCancel = True End Sub Private Sub Form_Unload(Cancel As Integer) test Cancel = CloseCancel End Sub Private Sub test() Dim acc As IAccessible, xy As POINTAPI, Child As Variant Dim NameIAcc As String GetCursorPos xy AccessibleObjectFromPoint PointToLongLong(xy), acc, Child If acc Is Nothing Then Exit Sub NameIAcc = vbCrLf & acc.accName(Child) Select Case acc.accRole(Child) Case ROLE_SYSTEM_LIST MsgBox "タスクバー:すべてのウィンドウを閉じる" & NameIAcc Case ROLE_SYSTEM_PUSHBUTTON MsgBox "コントロールボックス:閉じる" & NameIAcc Case ROLE_SYSTEM_BUTTONMENU MsgBox "システムメニュー:閉じる" & NameIAcc Case ROLE_SYSTEM_MENUITEM MsgBox "フォームアイコンダブルクリック" & NameIAcc Case ROLE_SYSTEM_PROPERTYPAGE '結果的にこうなる MsgBox "Applicationアイコンダブルクリック" & NameIAcc Case Else MsgBox "不明 もしくは、Backstageのコマンド" & NameIAcc End Select End Sub Private Sub cmdClose_Click() CloseCancel = False DoCmd.Close End Sub
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui"> <commands> <command idMso="WindowClose" onAction="onActionWindowClose" /> <command idMso="CloseDocument" onAction="onActionCloseDocument" /> <command idMso="FileCloseDatabase" onAction="onActionFileCloseDatabase" /> <command idMso="FileExit" onAction="onActionFileExit" /> </commands> </customUI>
0 件のコメント:
コメントを投稿