CodeItBetter Programming Another VB Programming Blog

'Forms - How to Create a Menu completely at Runtime
'In a Module:

Private 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 Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CreateMenu 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 lpNewItem As Any) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
    ByVal bRevert As Long) As Long
Private Const MF_ENABLED = &H0&
Private Const MF_POPUP = &H10&
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const WM_MENUSELECT = &H11F
Public Const GWL_WNDPROC = (-4)
Public lPrevWnd As Long
Public lSysMnu As Long
Public lMnu As Long
 
Public Sub CreateMenuBar()
    'Generate a Simple File Menu..
    Dim lSubMnu As Long
    Dim lRes As Long
    lMnu = CreateMenu 'Create a Menu Item
    lSubMnu = CreatePopupMenu 'Create a Popup Menu
    'Add Items to the Popup Menu
    'Each Item Requires a Unique ID to Identify it in our Menu Event
    lRes = AppendMenu(lSubMnu, MF_ENABLED Or MF_STRING, 1, ByVal "&Open")
    lRes = AppendMenu(lSubMnu, MF_ENABLED Or MF_STRING, 2, ByVal "&Save")
    lRes = AppendMenu(lSubMnu, MF_ENABLED Or MF_STRING, 3, ByVal "Save &As..")
    lRes = AppendMenu(lSubMnu, MF_ENABLED Or MF_STRING, 4, ByVal "&Exit")
    'Add the Popup Menu to the Main File Menu Item..
    lRes = AppendMenu(lMnu, MF_ENABLED Or MF_STRING Or MF_POPUP, lSubMnu, ByVal "File")
    'Assign the Menu to the Form
    lRes = SetMenu(Form1.hwnd, lMnu)
    'Draw the Menu, Only works when the Form is Visible.
    lRes = DrawMenuBar(Form1.hwnd)
End Sub
 
Public Function SubClassedForm(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
    Static lLastItemSelected As Long
    If Msg = &H105A Then
        'Redraw Menu
        Call SetMenu(Form1.hwnd, lMnu)
        Call DrawMenuBar(Form1.hwnd)
    ElseIf Msg = WM_MENUSELECT And lParam <> lSysMnu Then
        'Process Messages From Any of the Forms Menus, Except the System Menu
        If lParam Then
            'A Valid Item was Selected
            'Store the Index in the Static Var Until the Item is Clicked
            lLastItemSelected = wParam And 255
        Else
            'Call the MenuEvent Sub with the Last Selected Menu Item ID
            Call MenuEvent(lLastItemSelected)
            lLastItemSelected = 0
        End If
    End If
    SubClassedForm = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, lParam)
End Function
 
Public Sub MenuEvent(ByVal Index As Long)
    'Menu Item Code Goes Here,
    'Each Menu Item is Identified by it's Unique Index
    With Form1
        Select Case Index
            Case 1
                .Caption = "Open"
                'Open Item Code
            Case 2
                .Caption = "Save"
                'Save Item Code
            Case 3
                .Caption = "Save As.."
                'Save As Item Code
            Case 4
                .Caption = "Exit"
                'Exit Item Code
                Unload Form1
            Case Else
                .Caption = "No Item Selected"
        End Select
    End With
End Sub
 
'In the Form:

Private Sub Form_Load()
    'Get the System Menu Handle, so we don't process it's Messages
    lSysMnu = GetSystemMenu(hwnd, 0)
    'Sub-Class the Form to Capture the Menu Messages
    lPrevWnd = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf SubClassedForm)
    'Create the Menu Completely at Runtime.
    CreateMenuBar
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'Remove the Form Sub-Classing *** DO NOT REMOVE ***
    Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
End Sub