About This Code
Brief Description:
Popup Menus made easy in your applications
Contributor:
Andrew Jones
Last Modified:
17 Jun 2002
OpenNTF Disclaimer
All of the program code and information presented in the OpenNTF.org Code Bin are provided "as-is", and should be used at your own risk. OpenNTF.org make no express or implied warranty about anything in the Code Bin, and OpenNTF.org will not be responsible or liable for any damage caused by the use or misuse of anything from this site. OpenNTF.org makes no guarantees about anything. Please thoroughly test all of the knowledge and code you find here before you attempt to use them in your production environment.
Code / Description
+++ Create the following Lotus Script Agent, to test the application
{OPTIONS}
Option Public
Option Explicit
Use "PopupMenu"
{DECLARATIONS}
Sub Initialize
Dim Menus() As MenuHandles
Dim MenuString As String
Dim retval As Integer
'Prepare the menu and sub-menus
MenuString = "1. Menu Item 1\Sub Item 1;1. Menu Item 1\Sub Item 2;1. Menu Item 1\Sub Item 3;"
MenuString = MenuString + "-;"
MenuString = MenuString + "Menu Item 2;3. Menu Item 3\Sub Item 1;"
'Create menu structure
Call GetMenus(MenuString, Menus())
'Display the menus and wait for a menu selection
retval = PopupMenu(Menus())
Msgbox "The return value = " & retval,,"Popup Menu"
End Sub
+++ Create the following Script LIBRARY called "PopupMenu"
{OPTIONS}
Option Public
Option Explicit
Public Const MFS_ENABLED = &H0
Public Const MFS_DEFAULT = &H1000
Public Const MFS_CHECKED = &H8
Public Const MIIM_STATE = &H1
Public Const MIIM_ID = &H2
Public Const MIIM_SUBMENU = &H4
Public Const MIIM_TYPE = &H10
Public Const MFT_SEPARATOR = &H800
Public Const MFT_STRING = &H0
Public Const TPM_LEFTALIGN = &H0
Public Const TPM_TOPALIGN = &H0
Public Const TPM_NONOTIFY = &H80
Public Const TPM_RETURNCMD = &H100
Public Const TPM_LEFTBUTTON = &H0
Public Const MaxMenuItems = 20
Type MenuHandles
hMenu As Long
ID As Integer
Name As String
MenuCount As Integer
SubMenuCount As Integer
MenuItems(MaxMenuItems) As String
MenuID(MaxMenuItems) As Integer
End Type
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type POINT_TYPE
x As Long
y As Long
End Type
Public Type TPMPARAMS
cbSize As Long
rcExclude As RECT
End Type
Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Declare Function SetRectEmpty Lib "user32.dll" (lpRect As RECT) As Long
Declare Function GetCursorPos Lib "user32.dll" Alias "GetCursorPos" (lpPoint As POINT_TYPE) As Long
Declare Function CreatePopupMenu Lib "user32.dll" Alias "CreatePopupMenu" () As Long
Declare Function TrackPopupMenuEx Lib "user32.dll" (Byval hMenu As Long, Byval fuFlags As Long, Byval x As Long, Byval y As Long, Byval hWnd As Long, lptpm As TPMPARAMS) As Long
Declare Function DestroyMenu Lib "user32.dll" Alias "DestroyMenu" (Byval hMenu As Long) As Long
Declare Function GetActiveWindow Lib "user32.dll" Alias "GetActiveWindow" () As Long
Declare Function InsertMenuItem Lib "user32.dll" Alias "InsertMenuItemA" (Byval hMenu As Long, Byval uItem As Long, Byval fByPosition As Long, lpmii As MENUITEMINFO) As Long
+++ Paste the following functions into the script library
Function GetMenus(MenuString As String, menus() As MenuHandles) As Integer
Const MainMenu = 0
Dim MenuItem As String
Dim tMenuItem As String
Dim NumMenus As Integer
Dim NumItems As Integer
Dim nMenu As Integer
Dim MenuNumber As Integer
Dim Counter1 As Integer
Dim Counter2 As Integer
Dim Counter3 As Integer
Dim ID As Integer
NumMenus = 0
NumItems = 0
Redim Preserve Menus(NumMenus)
Menus(NumMenus).Name = "Main"
Menus(NumMenus).MenuCount = 0
Menus(NumMenus).SubMenuCount = 0
While Instr(MenuString, ";") > 1
MenuItem = Left$(MenuString, Instr(MenuString, ";") -1)
If Instr(MenuItem, "\") Then
tMenuItem = "%" & Left$(MenuItem, Instr(MenuItem, "\") -1)
If SubMenu(Menus, tMenuItem, nMenu) Then
MenuNumber = Menus(nMenu).MenuCount
Menus(nMenu).Menuitems(MenuNumber) = Right$(MenuItem, Len(Menuitem) - Instr(MenuItem, "") - 1)
Menus(nMenu).MenuCount = Menus(nMenu).MenuCount + 1
Else
Menus(MainMenu).SubMenuCount = Menus(MainMenu).SubMenuCount + 1
MenuNumber = Menus(MainMenu).MenuCount
Menus(MainMenu).Menuitems(MenuNumber) = tMenuItem
Menus(MainMenu).MenuCount = Menus(MainMenu).MenuCount + 1
NumMenus = NumMenus + 1
Redim Preserve Menus(NumMenus)
Menus(NumMenus).Name = Right$(tMenuItem, Len(tMenuItem) -1)
MenuNumber = Menus(NumMenus).MenuCount
Menus(NumMenus).MenuItems(MenuNumber) = Right$(MenuItem, Len(Menuitem) - Instr(MenuItem, "\") - 1)
Menus(NumMenus).MenuCount = Menus(NumMenus).MenuCount + 1
End If
Else
MenuNumber = Menus(MainMenu).MenuCount
Menus(MainMenu).Menuitems(MenuNumber) = MenuItem
Menus(MainMenu).MenuCount = Menus(MainMenu).MenuCount + 1
End If
MenuString = Right$(MenuString, Len(MenuString) - Instr(MenuString, ";"))
Wend
ID = 1
For Counter1 = 0 To Menus(MainMenu).MenuCount - 1
Menus(MainMenu).MenuID(Counter1) = ID
ID = ID + 1
MenuItem = Menus(MainMenu).MenuItems(Counter1)
If Left$(MenuItem, 1) = "%" Then
For Counter2 = 1 To Menus(MainMenu).SubMenuCount
If Menus(Counter2).Name = Right$(MenuItem, Len(MenuItem) -1) Then
Menus(Counter2).ID = ID - 1
For Counter3 = 0 To Menus(Counter2).MenuCount - 1
Menus(Counter2).MenuID(Counter3) = ID
ID = ID + 1
Next
End If
Next
End If
Next
End Function
Function PopupMenu(Menus() As Menuhandles) As Integer
Dim MenuCounter As Integer
Dim MenuCount2 As Integer
Dim hMenu As Double
Dim hMenuSub As Double
Dim ID As Integer
Dim itemCounter As Integer
Dim hWnd As Long
Dim mii As MENUITEMINFO
Dim tpm As TPMPARAMS
Dim curpos As POINT_TYPE
Dim retval As Long
For MenuCounter = Menus(0).SubMenuCount To 0 Step -1
hMenu = CreatePopupMenu()
Menus(MenuCounter).hMenu = hMenu
ItemCounter = 0
Forall MenuItems In Menus(MenuCounter).MenuItems
If MenuItems = "" Then Exit Forall
If Left$(MenuItems, 1) = "%" Then
For MenuCount2 = 1 To Menus(0).SubMenuCount
If Menus(MenuCount2).Name = Right$(MenuItems, Len(MenuItems) - 1) Then
hMenuSub = Menus(MenuCount2).hMenu
ID = Menus(MenuCount2).ID
End If
Next
mii.cbSize = Len(mii)
mii.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE Or MIIM_SUBMENU
mii.fType = MFT_STRING
mii.fState = MFS_ENABLED Or MFS_DEFAULT
mii.wID = ID
mii.hSubMenu = hMenuSub
mii.dwTypeData = Right$(MenuItems, Len(MenuItems) - 1)
mii.cch = Len(mii.dwTypeData)
retval = InsertMenuItem(hMenu, 0, False, mii)
ItemCounter = ItemCounter + 1
Else
If MenuItems = "-" Then
mii.cbSize = Len(mii)
mii.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
mii.fType = MFT_SEPARATOR
mii.fState = MFS_ENABLED
mii.wID = Menus(MenuCounter).MenuID(ItemCounter)
retval = InsertMenuItem(hMenu, 0, False, mii)
ItemCounter = ItemCounter + 1
Else
mii.cbSize = Len(mii)
mii.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
mii.fType = MFT_STRING
mii.fState = MFS_ENABLED Or MFS_DEFAULT
mii.wID = Menus(MenuCounter).MenuID(ItemCounter)
mii.dwTypeData = MenuItems
mii.cch = Len(mii.dwTypeData)
retval = InsertMenuItem(hMenu, 0, False, mii)
ItemCounter = ItemCounter + 1
End If
End If
End Forall
Next
retval = GetCursorPos(curpos)
hWnd = GetActiveWindow()
tpm.cbSize = Len(tpm)
retval = SetRectEmpty(tpm.rcExclude)
PopupMenu = TrackPopupMenuEx(hMenu, TPM_TOPALIGN Or TPM_LEFTALIGN Or TPM_NONOTIFY Or TPM_RETURNCMD Or TPM_LEFTBUTTON, curpos.x, curpos.y, hWnd, tpm)
For MenuCounter = Menus(0).SubMenuCount To 0 Step -1
DestroyMenu(Menus(MenuCounter).hMenu)
Next
End Function
Function SubMenu(Menus() As MenuHandles, tMenuItem As String, nMenuNumber As Integer) As Integer
Dim MenuCount As Integer
SubMenu = False
Forall MenuItem In Menus(0).MenuItems
If MenuItem = tMenuItem Then
SubMenu = True
For MenuCount = 1 To Menus(0).SubMenuCount
If Menus(MenuCount).Name = Right$(tMenuItem, Len(tMenuItem) -1) Then
nMenuNumber = MenuCount
End If
Next
Exit Forall
End If
End Forall
End Function
Usage / Example