标签：VBA，用户窗体
可以在鼠标处或者你想要的任意位置创建弹出菜单，如下图1所示。
图1
在VBE中，插入一个类模块，并将该模块重命名为“clsPopup”，输入代码：
代码语言：javascript复制Option Compare Text
Private m_hMenu As Long
'子菜单的标题部分是显示在父菜单上的选项
Public Caption As String
Private Declare PtrSafe Function SetMenuDefaultItem Lib "User32" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As Long
Private Declare PtrSafe Function CreatePopupMenu Lib "User32" () As Long
Private Declare PtrSafe Function DestroyMenu Lib "User32" (ByVal hMenu As Long) As Long
Private Declare PtrSafe Function AppendMenu Lib "User32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, lpNewItem As String) As Long
Private Declare PtrSafe Function EnableMenuItem Lib "User32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As Long
Private Declare PtrSafe Function RemoveMenu Lib "User32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private ItemCount As Long
Private Const MF_STRING = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_POPUP = &H10&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_GRAYED = &H1&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED As Long = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_BYPOSITION = &H400&
Private Const MF_REMOVE = &H1000&
Private Const APIFALSE As Long = 0
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTL) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "User32" () As Long
Private Declare PtrSafe 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, ByVal lprc As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "User32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "User32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Type POINTL
X As Long
Y As Long
End Type
Private Const TPM_RETURNCMD = &H100&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_LEFTBUTTON = &H0&
Private Declare PtrSafe Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Class_Initialize()
m_hMenu = CreatePopupMenu()
End Sub
Private Sub Class_Terminate()
DestroyMenu m_hMenu
End Sub
'返回对菜单的引用
Friend Property Get hMenu() As Long
hMenu = m_hMenu
End Property
'移除单个项目
Public Sub RemoveItem(ByVal nID As Long)
RemoveMenu m_hMenu, 0, MF_REMOVE Or MF_BYPOSITION
End Sub
'添加项目到菜单
Public Sub AddItem(ByVal nID As Long, _
varItem As Variant, _
Optional bDefault As Boolean = False, _
Optional bChecked As Boolean = False, _
Optional bDisabled As Boolean = False, _
Optional bGrayed As Boolean = False, _
Optional bNewColumn As Boolean = False)
If TypeName(varItem) = "String" Then
If varItem = "-" Then
AppendMenu m_hMenu, MF_STRING Or MF_SEPARATOR, nID, ByVal vbNullString
Else
AppendMenu m_hMenu, MF_STRING Or IIf(bNewColumn, MF_MENUBARBREAK, 0) Or IIf(bChecked, MF_CHECKED, 0), nID, ByVal varItem
End If
ElseIf TypeName(varItem) = "clsPopup" Then
Dim cSubMenu As clsPopup
Set cSubMenu = varItem
AppendMenu m_hMenu, MF_STRING Or MF_POPUP Or IIf(bNewColumn, MF_MENUBARBREAK, 0), cSubMenu.hMenu, ByVal cSubMenu.Caption
End If
If bDefault Then SetMenuDefaultItem m_hMenu, nID, APIFALSE
If bGrayed Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_GRAYED
If bDisabled Then EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or MF_DISABLED
ItemCount = ItemCount 1
End Sub
'返回项目的数量
Public Property Get Items() As Long
Items = ItemCount
End Property
'启用/禁用单个项目
Public Sub GreyItem(nID, Disabled As Boolean)
On Error Resume Next
EnableMenuItem m_hMenu, nID, MF_BYCOMMAND Or IIf(Disabled, MF_DISABLED, MF_ENABLED)
End Sub
'显示菜单并返回所选的主程序
Public Function PopUpMnu(Optional ByVal hwnd As Long = -1, _
Optional ByVal PopX As Long = -1, _
Optional ByVal PopY As Long = -1, _
Optional ByVal hWndOfBeneathControl As Long = -1) As Long
Dim h As Long
Dim X As Long
Dim Y As Long
If hwnd = -1 Or hwnd = 0 Then
'查找当前处理的顶部窗口
Dim hDesktop As Long
hDesktop = GetDesktopWindow()
'查找当前子窗口
Dim hChild As Long
hChild = GetWindow(hDesktop, GW_CHILD)
'获取ProcessID
Dim idCurrent As Long
idCurrent = GetCurrentProcessId()
Do While hChild
Dim idChild As Long
GetWindowThreadProcessId hChild, idChild
If idChild = idCurrent Then Exit Do
hChild = GetWindow(hChild, GW_HWNDNEXT)
Loop
If hChild = 0 Then Err.Raise -1, "cMenu.TrackPopup", "Cannot find top window of current process!"
h = hChild
Else
h = hwnd
End If
'传递一个默认控件以用作参考点?
If hWndOfBeneathControl <> -1 Then
Dim rt As RECT
GetWindowRect hWndOfBeneathControl, rt
X = rt.Left
Y = rt.Bottom
Else
'否则获取当前鼠标位置
Dim pt As POINTL
GetCursorPos pt
If PopX = -1 Then X = pt.X Else: X = PopX
If PopY = -1 Then Y = pt.Y Else: Y = PopY
End If
'显示菜单.
PopUpMnu = TrackPopupMenu(m_hMenu, TPM_RETURNCMD TPM_LEFTALIGN TPM_LEFTBUTTON, X, Y, 0, h, 0)
End Function插入一个标准模块来测试，在该模块中输入测试代码：
代码语言：javascript复制Option Compare Text
Public Sub PopUp()
Dim mnu As clsPopup
Dim mnuSub As clsPopup
On Error GoTo Catch
Set mnu = New clsPopup
Set mnuSub = New clsPopup
mnuSub.Caption = "测试4 (子菜单)"
With mnu
.AddItem 0, "测试1 (禁用)", , , True
.AddItem 1, "测试2 (默认)", True
.AddItem 2, "测试3 (已选取)", , True
.AddItem 3, mnuSub
.AddItem 5, "-"
.AddItem 6, "关闭菜单"
End With
With mnuSub
.AddItem 10, "子菜单1"
.AddItem 11, "子菜单2"
.AddItem 12, "子菜单3"
.AddItem 13, "子菜单4"
.AddItem 14, "子菜单5 (新列)", , , , , True
.AddItem 15, "子菜单6"
.AddItem 16, "子菜单7"
End With
'返回值将是在ADDITEM之后定义的值
Debug.Print mnu.PopUpMnu()
Set mnu = Nothing
Set mnuSub = Nothing
Catch:
End Sub注：本文的代码整理自ozgrid.com，供有兴趣的朋友研究。
