基本的にフォームだけなのだけど、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 件のコメント:
コメントを投稿