VBA创建弹出菜单

excelperfect

标签：VBA，用户窗体

可以在鼠标处或者你想要的任意位置创建弹出菜单，如下图1所示。

图1

在VBE中，插入一个类模块，并将该模块重命名为“clsPopup”，输入代码：

Option Compare TextPrivate m_hMenu As Long'子菜单的标题部分是显示在父菜单上的选项Public Caption As StringPrivate Declare PtrSafe Function SetMenuDefaultItem Lib 'User32' (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPos As Long) As LongPrivate Declare PtrSafe Function CreatePopupMenu Lib 'User32' () As LongPrivate Declare PtrSafe Function DestroyMenu Lib 'User32' (ByVal hMenu As Long) As LongPrivate Declare PtrSafe Function AppendMenu Lib 'User32' Alias 'AppendMenuA' (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, lpNewItem As String) As LongPrivate Declare PtrSafe Function EnableMenuItem Lib 'User32' (ByVal hMenu As Long, ByVal wIDEnableItem As Long, ByVal wEnable As Long) As LongPrivate Declare PtrSafe Function RemoveMenu Lib 'User32' (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As LongPrivate ItemCount As LongPrivate 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 = 0Private Declare PtrSafe Function GetCursorPos Lib 'User32' (lpPoint As POINTL) As LongPrivate Declare PtrSafe Function GetDesktopWindow Lib 'User32' () As LongPrivate 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 LongPrivate Declare PtrSafe Function GetWindow Lib 'User32' (ByVal hwnd As Long, ByVal wCmd As Long) As LongPrivate Declare PtrSafe Function GetWindowThreadProcessId Lib 'User32' (ByVal hwnd As Long, lpdwProcessId As Long) As LongPrivate Declare PtrSafe Function GetCurrentProcessId Lib 'kernel32' () As LongPrivate Const GW_CHILD = 5Private Const GW_HWNDNEXT = 2Private Type POINTL X As Long Y As LongEnd TypePrivate 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 LongPrivate Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd Type
Private Sub Class_Initialize() m_hMenu = CreatePopupMenu()End Sub
Private Sub Class_Terminate() DestroyMenu m_hMenuEnd Sub
'返回对菜单的引用Friend Property Get hMenu() As Long hMenu = m_hMenuEnd Property
'移除单个项目Public Sub RemoveItem(ByVal nID As Long) RemoveMenu m_hMenu, 0, MF_REMOVE Or MF_BYPOSITIONEnd 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 1End Sub
'返回项目的数量Public Property Get Items() As Long Items = ItemCountEnd 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

插入一个标准模块来测试，在该模块中输入测试代码：

Option Compare TextPublic 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 = NothingCatch:End Sub

注：本文的代码整理自ozgrid.com，供有兴趣的朋友研究。