2011/02/11

access2010 “閉じる”をできるだけ検知

閉じるということをできるだけ検知してみようとしている。
基本的にフォームだけなのだけど、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 件のコメント: