Menu

[QWERTY]

Is it possible to create a menu at a runtime?
Thanks in advance

QWERTY

[Aaron Young]

Here's some Code I put together and Posted Last week for someone with the same Question, Demonstrating 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

------------------
Aaron Young
Analyst Programmer
[email protected]
[email protected]


[This message has been edited by Aaron Young (edited 11-01-1999).]

[QWERTY]

Thanks!!!!!

[Kevin Burt]

Here's something I used when I was wanting to create some menu entries at run-time based on a ResultSet.

You might find it useful.

NB: At design time I created a control array entry called myMenu which is Visible, then called the following code.

Private Sub UpdateMenu()
         'This sub adds sub menu's to the form depending on how many items are returned by a resultset.

    Dim rsResultSet As rdoResultset
    Dim iArray As Integer
    
    iArray = 1
    
    Set rsResultSet = myConnection.OpenResultset("Select myItem From myTable Where myItem = myCondition)
    
    'If there are any items returned, add to the menu item array until we reach the end of the resultset.
    If Not (rsResultSet.BOF And rsResultSet.EOF) Then
        'Because an invisible occurance of  myMenu control array already exists when the form
        'is first created, we can rename this sub menu to have a caption describing the first
        'Item and make it visible.
        rsResultSet.MoveFirst
        myForm.myMenu(0).Caption = rsResultSet![myItem]
        rsResultSet.MoveNext
        
        With myForm
            While Not rsResultSet.EOF
                'For any additional Items that are returned, create a new instance of the menu control array.
                Load .myMenu(iArray)
                .myMenu(iArray).Caption = rsResultSet![myItem]
                .myMenu(iArray).Visible = True
                iArray = iArray + 1
                rsResultSet.MoveNext
            Wend
        End With
    Else
        'If no Items are returned then disable the option completely, by hiding the
        'preceding sub menu's.
        myForm.myMenuMain.Visible = False
    End If
        
    'Close the recordset and free up system memory.
    rsResultSet.Close
    Set rsResultSet = Nothing
End Sub

[This message has been edited by Kevin Burt (edited 11-02-1999).]