[讨论]关于在VBA中创建快捷菜单的问题

zfbj

下面的语句能在用户单击鼠标右键时弹出一个快捷菜单，但是位置不正确。
窗体中的代码：
Option Explicit

Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim hPopupMenu As Long
    Dim lResult As Long
    Dim xScale As Double
    Dim yScale As Double
   
    xScale = GetDeviceCaps(GetWindowDC(GetActiveWindow()), LOGPIXELSX)
    yScale = GetDeviceCaps(GetWindowDC(GetActiveWindow()), LOGPIXELSY)
   
    If Button = 1 Then Exit Sub
   
    hPopupMenu = CreatePopupMenu()
        
    lResult = AppendMenu(hPopupMenu, MF_STRING, IDM_NEW, "&File")
    lResult = AppendMenu(hPopupMenu, MF_STRING, IDM_OPEN, "&Open")
   
    lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, (Me.Left + X) * 1440 / xScale, (Me.Top + Y) * 1440 / yScale, 0&, GetActiveWindow, vbNull)
   
End Sub

标准模块中的代码：
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function AppendMenu Lib "user32" _
    Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, _
                        ByVal lpNewItem As Any) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, _
                                                    ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, _
                                                    ByVal hwnd As Long, lprc As Any) As Long    ' 最后一个参数类型改为Any(从RECT)
' Flags for TrackPopupMenu
Public Const TPM_CENTERALIGN = &H4&
Public Const TPM_LEFTALIGN = &H0&
Public Const TPM_LEFTBUTTON = &H0&
Public Const TPM_RIGHTALIGN = &H8&
Public Const TPM_RIGHTBUTTON = &H2&

Public Const WM_COMMAND = &H111

Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Const MF_STRING = &H0&
Public Const MF_BITMAP = &H4&


Public Const IDM_NEW As Long = 1001
Public Const IDM_OPEN As Long = 1002

1. 程序代码内容

复制代码

1. 程序代码内容

复制代码

请几位版主和各位看一看，能否使弹出菜单显示在正确的位置上？
你也可以下载相关的程序。

mccad

1.     lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, (Me.Left + X) * 100 / 75, _
   
2.                             (Me.Top + Y) * 100 / 75, 0&, GetActiveWindow, vbNull)
   

复制代码

zfbj

可是对于不同的显示器，这个比率应该是不固定的吧。

wyj7485

我使用以下语句刚好合适: lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, (Me.Left + X + 120), _
(Me.top + Y + 40), 0&, GetActiveWindow, vbNull) 换个机子好象又不行了.

wyj7485

请问如何把我的程序与单击快捷菜单上的条目联系起来呢? 也就是如何利用快捷菜单上的条目来处理我的程序.

wyj7485

'类加入 Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Type POINTAPI
x As Long
y As Long
End Type '窗体加入 Dim Pt As POINTAPI

GetCursorPos Pt
lResult = TrackPopupMenu(hPopupMenu, TPM_LEFTALIGN Or TPM_LEFTBUTTON, _
Pt.x, Pt.y, 0, GetActiveWindow, 0&) '这样完全解决了快捷菜单跟随鼠标的问题.

木子歌

就是呀，好好玩，不过我从来没用VBA做过菜单呢，包括屏幕菜单，改日我也做做