Adding a Menu to a UserForm !

Jaafar Tribak · Jul 1, 2004

Hi all,

I have been experimenting with this rather unusual area and found some difficulties.

The code below successfully adds a Menu Bar to a UserForm.It then adds a PopUp Menu Item to it and Two SubMenu items to the newly created PopUp Menu item.

The Two SubMenu Items are supposed to display a simple MsgBox each upon clicking on them.

The problem I am having is that these MsgBoxes appear when hovering the Mouse Cursor over the Submenu Items instead of appearing when clicking on them.

Any suggestions on how I could fix this would be much appreciated.

Ah, another thing : I would love to add like a FaceId or another Graphic to the SubMenus as well but I have been unsuccessful so far.

Code in a Standard Module :

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

Public Declare Function CreateMenu Lib "user32" () As Long

Public Declare Function CreatePopupMenu Lib "user32" () 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 String) As Long

Public Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

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

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function CallWindowProc Lib _
"user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Integer, ByVal Source As Long, ByVal Length As Long)

Public Const MF_POPUP = &H10
Public Const MF_STRING = &H0
Public Const WM_MENUSELECT = &H11F
Public Const GWL_WNDPROC = -4

Public hForm As Long
Public hMenu As Long
Public hPopUpMenu As Long
Public lpPrevWndProc As Long
Public Rt As Long

 ' Get the PopUpMenu index stored in the low integer of wParam
Public Function LOWORD(dw As Long) As Integer
 CopyMemory LOWORD, VarPtr(dw), 2
End Function

Public Function CustomWinProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

 ' Catch the MenuSelect message and display MsgBoxes
 If uMsg = WM_MENUSELECT And LOWORD(wParam) <> 0 Then
 MsgBox "Hello ! You Selected PopUp " & LOWORD(wParam)
 End If

 ' Reroute all messages to native window procedure
 CustomWinProc = CallWindowProc _
 (lpPrevWndProc, hw, uMsg, wParam, lParam)

End Function


Code in the UserForm Class Module :

Private Sub UserForm_Initialize()

 ' Retrieve the Form Handle
 hForm = FindWindow(vbNullString, Me.Caption)

 ' Create Menu and PopUp
 hMenu = CreateMenu()
 hPopUpMenu = CreatePopupMenu()

 ' Add Them To The Form
 Rt = AppendMenu(hPopUpMenu, MF_STRING, 1, "PopUp 1")
 Rt = AppendMenu(hPopUpMenu, MF_STRING, 2, "PopUp 2")
 Rt = AppendMenu(hMenu, MF_POPUP, hPopUpMenu, "Jaafar")
 Rt = SetMenu(hForm, hMenu)

 ' Subclass The Form
 lpPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf CustomWinProc)

End Sub

Private Sub UserForm_Terminate()

 ' Clean up
 DestroyMenu hMenu
 SetWindowLong hForm, GWL_WNDPROC, lpPrevWndProc

End Sub


Regards.

Ivan F Moala · Jul 1, 2004

I have example workbooks on doing this using 2 methods

1) API activated with Right click on userform
2) using native commandbars, so you can set the graphics etc.

let me know if you want it...... it is from a project I have yet to post to my site...

Jaafar Tribak · Jul 1, 2004

Ivan F Moala said:
I have example workbooks on doing this using 2 methods

1) API activated with Right click on userform
2) using native commandbars, so you can set the graphics etc.

let me know if you want it...... it is from a project I have yet to post to my site...

Yes please to my Email address.

Thanks very much.

Jaafar Tribak · Jul 2, 2004

Hi again,

I seem to have a problem receiving Mails sent from this board. :x
I Have sent a couple of test Emails to myself using the Email Button below but received nothing in my Yahoo inbox !

I am not sure why this is happening !

Jaafar Tribak · Jul 2, 2004

I am now trying to add a Bitmap Picture to the first PopUp Menu Item(entry) but when I display the Form and Click on the Menu, the first entry is Blank instead of it displaying the Bitmap !

The second entry works OK and displays the string PopUp 2 as expected.

I have even tried other API functions like ModifyMenu and GetMenuItemID but without any luck.

I don't know what I am missing but the sequence of code lines seems logical to me.

By the way, Ivan, I didn't receive the workbook samples you mentioned.Did you send them or is it my email which is not working ?

Here is the amended Code that caters for the Bitmap picture:

1) In the Standard Module:

 ' APIs And Constantes Declarations
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function CreateMenu Lib "user32" () As Long

Public Declare Function CreatePopupMenu Lib "user32" () 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 String) As Long

Public Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

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

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Declare Function CallWindowProc Lib _
"user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Integer, ByVal Source As Long, ByVal Length As Long)

Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" _
(ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, _
ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Public Const MF_POPUP = &H10
Public Const MF_STRING = &H0
Public Const WM_MENUSELECT = &H11F
Public Const GWL_WNDPROC = -4
Public Const MF_BITMAP = &H4&
Public Const IMAGE_BITMAP = 0
Public Const LR_LOADFROMFILE = &H10
Public Const BMP_Full_Path = "C:\Pretty.bmp" ' BitMap File

Public hForm As Long
Public hMenu As Long
Public hPopUpMenu As Long
Public lpPrevWndProc As Long
Public Rt As Long
Public hBMP As Long

 ' Get the PopUpMenu index stored in the low integer of wParam
Public Function LOWORD(dw As Long) As Integer
 CopyMemory LOWORD, VarPtr(dw), 2
End Function

Public Function CustomWinProc(ByVal hw As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long

 ' Catch the MenuSelect message and display MsgBoxes
 If uMsg = WM_MENUSELECT And LOWORD(wParam) <> 0 Then
 MsgBox "Hello ! You Selected PopUp " & LOWORD(wParam)
 End If

 ' Reroute all messages to native window procedure
 CustomWinProc = CallWindowProc _
 (lpPrevWndProc, hw, uMsg, wParam, lParam)

End Function


2) In The Form Class Module:

Private Sub UserForm_Initialize()

 ' Retrieve the Form Handle
 hForm = FindWindow(vbNullString, Me.Caption)

 ' Create Menu and PopUp
 hMenu = CreateMenu()
 hPopUpMenu = CreatePopupMenu()

 ' Get The Handle To A BitMap File
 hBMP = LoadImage(0, BMP_Full_Path, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)

 ' Append The BitMap To The First PopUp SubMenu Item
 ' This Doesn't Seem To Work !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 Rt = AppendMenu(hPopUpMenu, MF_BITMAP, 1, hBMP)

 ' Append The String " PopUp 2 " To The Second PopUp SubMenu Item
 Rt = AppendMenu(hPopUpMenu, MF_STRING, 2, "PopUp 2")

 ' Add Menu To The Form
 Rt = AppendMenu(hMenu, MF_POPUP, hPopUpMenu, "Jaafar")
 Rt = SetMenu(hForm, hMenu)

 ' Subclass The Form
 lpPrevWndProc = SetWindowLong(hForm, GWL_WNDPROC, AddressOf CustomWinProc)

End Sub

Private Sub UserForm_Terminate()

 ' Clean up
 DestroyMenu hPopUpMenu
 DestroyMenu hMenu
 SetWindowLong hForm, GWL_WNDPROC, lpPrevWndProc

End Sub


Regards.

sudhakar · Jul 29, 2004

hello,

Given sample is working fine. but i need on click event. this is invoking msgbox when mouse move over it..

can i get how i can get the moveclick on the menu items.

thanks in advance
Sudhakar

Ivan F Moala · Sep 13, 2004

It is the WM_COMMAND that you need to Monitor

eg WM_COMMAND And (wParam And &HFFFF&) <> 0

Note: (wParam And &HFFFF&) yields the same result that you have for the lowbyte function.

Also for BMP images.....
1) Images need to be 13 X 13 Pixels or a least for me.
2) Image index positions are zero based ie 1st is 0 and not 1

MartinS · Dec 22, 2004

Hi
Excellent solution to a problem I've ben having BUT when I click to open the menu, it always returns the message that I selected Popup 1, i.e. the mouse will not go past the first option - is there a way that the click event can be used instead of hover over?
Secondly, how do I add more than one menu? and also how do i attach the appropriate routines to each item of the menu?
Any help gratefully received
Regards
Martin

Ivan F Moala · Jan 27, 2005

Hi martin

I will have a solution up on my site soon .......unless you want to get one now ... then email me.

Adding a Menu to a UserForm !

Jaafar Tribak

Well-known Member

Excel Facts

Ivan F Moala

MrExcel MVP

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

Jaafar Tribak

Well-known Member

sudhakar

New Member

Ivan F Moala

MrExcel MVP

MartinS

Active Member

Ivan F Moala

MrExcel MVP

Similar threads

Forum statistics

Share this page

Adding a Menu to a UserForm !

Well-known Member

Excel Facts

MrExcel MVP

Well-known Member

Well-known Member

Well-known Member

New Member

MrExcel MVP

Active Member

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock