Windows10下Access VBA托盘图标右键弹出菜单失效问题排查

问题背景 #

原有Access程序（accde）启动后最小化到系统托盘，右键托盘图标可弹出功能菜单，所有功能正常。适配64位与VB7版本后，其他功能无异常，但TrackPopupMenu函数始终返回0，托盘右键菜单无法显示。

核心错误点与修复步骤 #

1. 修正TrackPopupMenu的API声明参数类型 #

原声明中wFlags、X、Y、nReserved错误使用了LongPtr类型，不符合64位Windows API规范，需改为Long：

Public Declare PtrSafe Function TrackPopupMenu Lib "USER32" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As LongPtr, lprc As Any) As Long

2. 适配MENUITEMINFO结构体的cbSize #

64位系统下MENUITEMINFO结构体大小与32位不同，不能直接用Len(MenItemInf)，需通过条件编译设置正确值：

#If VBA7 Then
    ' 64位系统下结构体大小为80字节
    MenItemInf.cbSize = 80
#Else
    ' 32位系统下为44字节
    MenItemInf.cbSize = 44
#End If

3. 处理TrackPopupMenu的区域参数 #

原代码传递了未初始化的RECT变量，导致函数调用失败。若无需限制菜单显示区域，直接传递ByVal 0&：

lngRetVal1 = TrackPopupMenu(hMen, TPM_BOTTOMALIGN Or TPM_LEFTBUTTON Or TPM_NOANIMATION, curPoint.X, curPoint.Y, 0, Application.hWndAccessApp, ByVal 0&)

4. 补充必要的常量定义 #

确保所有用到的常量值正确，避免因未定义导致的错误：

' 菜单相关常量
Public Const MIIM_STATE = &H1
Public Const MIIM_TYPE = &H10
Public Const MIIM_ID = &H2
Public Const MFT_STRING = &H0
Public Const MF_ENABLED = &H0&

' TrackPopupMenu常量
Public Const TPM_BOTTOMALIGN = &H20&
Public Const TPM_LEFTBUTTON = &H0&
Public Const TPM_NOANIMATION = &H400&

' 菜单ID常量（根据实际业务调整）
Public Const lngRESTORE_WINDOW = 1001
Public Const lngEXIT_APP = 1003

修正后的完整代码示例 #

' 常量定义
Public Const MIIM_STATE = &H1
Public Const MIIM_TYPE = &H10
Public Const MIIM_ID = &H2
Public Const MFT_STRING = &H0
Public Const MF_ENABLED = &H0&

Public Const TPM_BOTTOMALIGN = &H20&
Public Const TPM_LEFTBUTTON = &H0&
Public Const TPM_NOANIMATION = &H400&

Public Const lngRESTORE_WINDOW = 1001
Public Const lngEXIT_APP = 1003

' 64位适配的API声明
Public Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Public Declare PtrSafe Function CreatePopupMenu Lib "USER32" () As LongPtr
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 Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As LongPtr, lprc As Any) As Long
Public Declare PtrSafe Function DestroyMenu Lib "USER32" (ByVal hMenu As LongPtr) As Long

' 结构体定义
Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As LongPtr
    hbmpChecked As LongPtr
    hbmpUnchecked As LongPtr
    dwItemData As LongPtr
    dwTypeData As String
    cch As Long
    hbmpItem As LongPtr
End Type

Public Function buildMenu() As LongPtr
    Dim hMenu   As LongPtr
    hMenu = CreatePopupMenu
    
    Call addMenuItem(hMenu, lngRESTORE_WINDOW, "Mostra Pantalla")
    Call addMenuItem(hMenu, lngEXIT_APP, "Sortir")
    
    buildMenu = hMenu
End Function

Private Sub addMenuItem(hMenu As LongPtr, ItemID As Long, ItemText As String)
    Dim MenItemInf As MENUITEMINFO

    With MenItemInf
        #If VBA7 Then
            .cbSize = 80
        #Else
            .cbSize = 44
        #End If
        .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, True, MenItemInf)
End Sub

Private Sub trayIconRClick()
    Dim hMen As LongPtr
    Dim lngRetVal As Long, lngRetVal1 As Long
    Dim curPoint As POINTAPI
     
    hMen = buildMenu()
    lngRetVal = GetCursorPos(curPoint)

    If lngRetVal <> 0 Then
        lngRetVal1 = TrackPopupMenu(hMen, TPM_BOTTOMALIGN Or TPM_LEFTBUTTON Or TPM_NOANIMATION, curPoint.X, curPoint.Y, 0, Application.hWndAccessApp, ByVal 0&)

        If lngRetVal1 <> 0 Then
            Select Case lngRetVal1
            Case lngRESTORE_WINDOW
                DoCmd.Restore
                Call bringWindowToFront(Me.hWnd)
            Case lngEXIT_APP
                DoCmd.Close acForm, Me.Name, acSaveNo
                
                On Error Resume Next
                Call unregisterIcon
                Call DeleteObject(hIcon)
                Application.Quit (acQuitSaveNone)
            End Select
        End If
    End If

    Call DestroyMenu(hMen)
End Sub

额外注意事项 #

• 代码中bringWindowToFront、unregisterIcon、DeleteObject、hIcon等未定义的函数/变量，需同步完成64位适配
• 编译accde前，确保VBA编辑器中所有依赖的API、常量、结构体都已正确定义

内容的提问来源于stack exchange，提问作者user1977269