Right Click Menu on VBA Form?

[Anonymous]

In VB5/6 it's easy with the menu editor and the "PopupMenu mnuName"
command. I don't see any thing in the VBA documentation. I suppose
worst case I could throw up another small form with labels.

Anyone know any tricks/winapi options.

Thanks in advance.

Terry

[Anonymous]

Hi Terry,
You rang?

Option Explicit

' THE API STRIKES AGAIN
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' A Painful introduction into using the
' The WIN32API to fill in the gaps between
' VBA and Visual Basic.

' These are TYPES - Like an Array, but each
' Element can be a different data type.

Private 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

Private Type POINTAPI
x As Long
y As Long
End Type

' These are Functions in Windows Dynamic Link
' Libraries. By using the syntax you see here,
' We use these functions in our VBA projects
' Perhaps the most important thing to remember
' When you start experimenting with this code:
' SAVE - SAVE - SAVE

Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

Private Declare Function CreatePopupMenu Lib _
"user32" () As Long

Private Declare Function TrackPopupMenuEx Lib "user32" _
(ByVal hMenu As Long, ByVal un As Long, _
ByVal n1 As Long, ByVal n2 As Long, _
ByVal hwnd As Long, lpTPMParams As Any) As Long

Private Declare Function InsertMenuItem Lib "user32" _
Alias "InsertMenuItemA" (ByVal hMenu As Long, _
ByVal un As Long, ByVal bool As Long, _
lpcMenuItemInfo As MENUITEMINFO) As Long

Private Declare Function DestroyMenu Lib "user32" _
(ByVal hMenu As Long) As Long

Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

' These are constants (Fixed values) used in
' Calls to the functions listed above.
Private Const MF_STRING = &H0&
Private Const TPM_RETURNCMD = &H100&
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20

' These are variables used in the
' Events and procedures..
Dim lngMnu As Long
Dim lngHwnd As Long
Dim lngID As Long
Dim PT As POINTAPI
Dim objMNU As MENUITEMINFO

'And the Events Begin!

Private Sub UserForm_Initialize()
Dim strArray(1 To 3) As String
Dim lngCnt As Long
strArray(1) = "Cut"
strArray(2) = "Copy"
strArray(3) = "Paste"
lngMnu = CreatePopupMenu()
lngHwnd = FindWindow(vbNullString, Me.Caption)
For lngCnt = 1 To 3
With objMNU
.cbSize = Len(objMNU)
.fMask = MIIM_TYPE Or MIIM_ID Or MIIM_DATA
.dwTypeData = strArray(lngCnt)
.cch = Len(strArray(lngCnt))
.fType = MF_STRING
.wID = lngCnt
End With
Call InsertMenuItem(lngMnu, lngCnt, 1, objMNU)
Next lngCnt
End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 2 Then
GetCursorPos PT
lngID = TrackPopupMenuEx(lngMnu, TPM_RETURNCMD, PT.x, _
PT.y, lngHwnd, ByVal 0&)
Select Case lngID
Case 1
TextBox1.Cut
Case 2
TextBox1.Copy
Case 3
TextBox1.Paste
End Select
End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call DestroyMenu(lngMnu)
End Sub

Randall Rath
VB Design

[Anonymous]

The code below is a popup-menu class. Create a class module called
PopupMenu and paste the code in. To use, just use the MouseUp event of a
control and check for right button (2). See the MouseUp example below the
class code to see how it is used. Good luck!
- Lanny

'<<<<<<<<< B E G I N C L A S S C O D E >>>>>>>>>> ... watch for word
wrap!

Option Explicit
'
Private Type Point
X As Long
Y As Long
End Type
'
Private Const MF_ENABLED = &H0&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const TPM_RIGHTBUTTON = &H2&
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_NONOTIFY = &H80&
Private Const TPM_RETURNCMD = &H100&
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal
hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal
sCaption As String) As Long
Private 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, nIgnored As Long) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As
Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Point) As
Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'
Public Function Popup(ParamArray param()) As Long
Dim iMenu As Long
Dim hMenu As Long
Dim nMenus As Long
Dim p As Point

' get the current cursor pos in screen coordinates
GetCursorPos p

' create an empty popup menu
hMenu = CreatePopupMenu()

' determine # of strings in paramarray
nMenus = 1 + UBound(param)

' put each string in the menu
For iMenu = 1 To nMenus
' the AppendMenu function has been superseeded by the InsertMenuItem
' function, but it is a bit easier to use.
If Trim$(CStr(param(iMenu - 1))) = "-" Then
' if the parameter is a single dash, a separator is drawn
AppendMenu hMenu, MF_SEPARATOR, iMenu, ""
Else
AppendMenu hMenu, MF_STRING + MF_ENABLED, iMenu,
CStr(param(iMenu - 1))
End If
Next iMenu

' show the menu at the current cursor location;
' the flags make the menu aligned to the right (!); enable the right button
to select
' an item; prohibit the menu from sending messages and make it return the
index of
' the selected item.
' the TrackPopupMenu function returns when the user selected a menu item or
cancelled
' the window handle used here may be any window handle from your application
' the return value is the (1-based) index of the menu item or 0 in case of
cancelling
iMenu = TrackPopupMenu(hMenu, TPM_RIGHTBUTTON + TPM_LEFTALIGN +
TPM_NONOTIFY + TPM_RETURNCMD, p.X, p.Y, 0, GetForegroundWindow(), 0)

' release and destroy the menu (for sanity)
DestroyMenu hMenu

' return the selected menu item's index
Popup = iMenu

End Function





'<<<<<<<<< B E G I N M O U S E - U P C O D E >>>>>>>>>> ... watch for
word wrap!

Private Sub lvwLayouts_MouseUp _
(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As stdole.OLE_XPOS_PIXELS, _
ByVal Y As stdole.OLE_YPOS_PIXELS)

Dim objMenu As PopupMenu
Dim MenuLine As Long
Dim i As Integer

If Button = 2 Then 'Rightbutton
Set objMenu = New PopupMenu

MenuLine = objMenu.Popup( _
"Select All", _
"Clear All", _
"Invert Selections")

Select Case MenuLine
Case 1 'Select All
With lvwLayouts.ListItems
For i = 1 To .Count
.Item(i).Checked = True
Next
End With
Case 2 'Clear All
With lvwLayouts.ListItems
For i = 1 To .Count
.Item(i).Checked = False
Next
End With
Case 3 'Invert
With lvwLayouts.ListItems
For i = 1 To .Count
.Item(i).Checked = Not .Item(i).Checked
Next
End With
End Select
CountTotalSelected
End If
End Sub

[Anonymous]

"Terry W. Dotson" wrote:

> Anyone know any tricks/winapi options.

Isn't this a great place, you have a problem and sometimes 15 minutes
later you've got quality answers.

Thanks again Randall/Lanny.

Terry