如何在 windows 10 上使用访问 vba 系统托盘显示弹出菜单

Question

我有一个在系统托盘上开始最小化的访问程序 (accde)。 当用户单击系统托盘程序图标时，必须显示一个弹出菜单。 从今天开始，一切都很完美。 今天我已经为 64 位和 vb7 改编了程序。 除了在系统托盘上显示弹出菜单外，它可以正常工作。它没有被显示。 Function "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

Answer 1

我找到了解决方案。 Function 必须使用 InsertMenu 代替 InsertMenuItem。 我贴出必须更改的 function 的代码，

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