如何在 Windows 10 上使用 Access VBA 系统托盘显示弹出菜单？答案

【问题标题】：How to show popup menu with Access VBA systray on Windows 10?如何在 Windows 10 上使用 Access VBA 系统托盘显示弹出菜单？
【发布时间】：2023-01-12 20:30:51
【问题描述】：

我有一个在系统托盘上最小化启动的 Access 程序 (accde)。
当用户单击系统托盘程序图标时，必须显示一个弹出菜单。
一直工作到今天。

今天我将程序改编为 64 位和 vb7。
它可以工作，但它不会在系统托盘上显示弹出菜单。
函数“TrackPopupMenu”始终返回 0。

Public Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As LongPublic Declare PtrSafe Function CreatePopupMenu Lib "USER32" () As LongPtr
Public Declare PtrSafe Function InsertMenu Lib "USER32" Alias "InsertMenuA" (ByVal hMenu As LongPtr, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
Public Declare PtrSafe Function InsertMenuItem Lib "USER32" Alias "InsertMenuItemA" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Public Declare PtrSafe Function TrackPopupMenu Lib "USER32" (ByVal hMenu As LongPtr, ByVal wFlags As LongPtr, ByVal X As LongPtr, ByVal Y As LongPtr, ByVal nReserved As LongPtr, ByVal hWnd As LongPtr, lprc As RECT) As LongPtr
               
Public Declare PtrSafe Function DestroyMenu Lib "USER32" (ByVal hMenu As LongPtr) As Long
    
Public Function buildMenu() As LongPtr

    ' Office Commandbars do not work well when displayed over the taskbar
    ' therefor we'll create the context-menu by API-Calls.
    
    Dim hMenu   As LongPtr
    
    ' Creating the PopUpMenu
    hMenu = CreatePopupMenu
    
    ' Inserting the MenuItems in the PopUpMenu
    Call addMenuItem(hMenu, lngRESTORE_WINDOW, "Mostra Pantalla")
    'Call addMenuItem(hMenu, lngSHOW_ACCESSWINDOW, "Show Access Window")
    Call addMenuItem(hMenu, lngEXIT_APP, "Sortir")
    
    ' Return the handle to the PopUpMenu
    buildMenu = hMenu
End Function
    
Private Sub addMenuItem(hMenu As LongPtr, ItemID As Long, ItemText As String)

    Dim MenItemInf As MENUITEMINFO

    With MenItemInf
        .cbSize = Len(MenItemInf)
        .fState = MF_ENABLED
        .fMask = MIIM_STATE Or MIIM_TYPE Or MIIM_ID
        .fType = MFT_STRING
        .dwItemData = 0
        .cch = Len(ItemText)
        .hSubMenu = 0
        .wID = ItemID
        .dwTypeData = ItemText
        .hbmpChecked = 0
        .hbmpUnchecked = 0
    End With
    
    Call InsertMenuItem(hMenu, 0, 1, MenItemInf)
    
End Sub
    
Private Sub trayIconRClick()
    
    Dim hMen As LongPtr
    Dim lngRetVal, lngRetVal1 As LongPtr
    Dim curPoint As POINTAPI
    Dim lptrREct As RECT
     
    ' Build the systray-contextmenu an retrieve the handle
    hMen = buildMenu()

    ' get the actual cursor position
    lngRetVal = GetCursorPos(curPoint)

    If lngRetVal <> 0 Then
        ' Show the systray-contextmenu at the cursor-position
         
        lngRetVal1 = TrackPopupMenu(hMen, TPM_BOTTOMALIGN Or TPM_LEFTBUTTON Or TPM_NOANIMATION, curPoint.X, curPoint.Y, 0, Application.hWndAccessApp, lptrREct)

        If lngRetVal1 <> 0 Then
            ' check which menuitem was clicked
            Select Case lngRetVal
            Case lngRESTORE_WINDOW
                DoCmd.Restore
                Call bringWindowToFront(Me.hWnd)
            Case lngSHOW_ACCESSWINDOW
                Call ShowWindow(Application.hWndAccessApp, SW_SHOW)
            Case lngEXIT_APP
                DoCmd.Close acForm, Me.Name, acSaveNo
                
                On Error Resume Next
                Call unregisterIcon
                ' Free icon-resources
                Call DeleteObject(hIcon)
                Application.Quit (acQuitSaveNone)
            
            End Select
        End If
    
    End If

    ' Free menu-ressources
    Call DestroyMenu(hMen)
End Sub

【问题讨论】：

P/Invoke 声明非常疯狂。我没有仔细看，但 wFlags 绝对不是指针大小的。它被声明为 32 位无符号值。我不知道这会在 VBA 中转化为什么。
您好 IInspectable：我已经尝试过了，但仍然无法正常工作。弹出菜单不出现。非常感谢您的帮助。

标签： vba ms-access winapi windows-10 systray

【解决方案1】：

必须使用函数 InsertMenu 代替 InsertMenuItem。

Public Function buildMenu() As LongPtr

    ' Office Commandbars do not work well when displayed over the taskbar
    ' therefor we'll create the context-menu by API-Calls.
    
    Dim hMenu   As LongPtr
    
    ' Creating the PopUpMenu
    hMenu = CreatePopupMenu
    
    InsertMenu hMenu, 0, MF_BYCOMMAND Or MF_STRING, lngRESTORE_WINDOW, "Mostra Pantalla"
    InsertMenu hMenu, 0, MF_BYCOMMAND Or MF_STRING, lngEXIT_APP, "Sortir"
    
    ' Return the handle to the PopUpMenu
    buildMenu = hMenu
    
End Function

【讨论】：