Create dynamic menu in VB6

Question

What seemed to be simple and easy, became a nightmare...

The idea of a dynamic menu is simple. Just create menus, items and sub-items according to the database. However, the tool available by the basic visual 6 is very limited and does not allow the construction of the menu to be so dynamic.

I tried to use the Smartmenuxp component to build a fully dynamic menu, however, despite achieving my goal, there were some problems that prevented me from progressing with the use of this component. This bar (Smartmenuxp) was allocated in the main MDI of the project, but when opening child forms, the control box of the child Forms exceeded the menu and the controls (Minimize, Close, Maximize) were above the menu and below the mdi controls. I searched all available information, read all product documentation and searched all properties... but could not solve the problem.

I would like to find an easy-to-use API/Component to create a menu bar, or standard menus.

Answer 1

Unfortunately VB6 does not allow to do this using only the VB. Should be used an external component or the Windows API.

I created a small example of how to do this using Windows Apis.

For the example was created a Form (Form1) and a Module (Module1).

Initially, the Form1 has the following menu bar:

While running the program, the example adds a tab and three extra menus:

The Module1 has the following important functions for the Form1:

• PreparaForm1: prepares the Form1 to add and handle dynamic menus

• AdicionaItem: adds an item to an existing menu (for security, not to conflict with the id’s of the native VB menus, choose high id’s such as 16000, 16001 ... up to 65534)

• AdicionaSubMenu: adds an item to an existing menu, but this item will act as a submenu

• AdicionaSeparador: adds a tab to an existing menu

• RemoveItemPorIndice: removes an item (according to its index/position) from an existing menu

• RemoveItemPorId: removes an item (according to its id) from an existing menu

There are also four other functions to work with items in submenus, they work in the same way as the others, but act on a submenu, within a menu: AdicionaItemSub, AdicionaSeparadorSub, RemoveItemPorIndiceSub and RemoveItemPorIdSub

Code of Example Form1

Option Explicit

Public Function MenuClicado(ByVal id As Long) As Boolean
    MenuClicado = True

    Select Case id
    Case 16001
        MsgBox "Menu dinâmico 1: vou excluir o menu no índice 1"
        'Exclui o menu com o índice 1
        Module1.RemoveItemPorIndice 0, 1
    Case 16002
        MsgBox "Menu dinâmico 2: vou excluir o Menu dinâmico 3"
        'Exclui o Menu dinâmico 3 através do seu id
        Module1.RemoveItemPorId 0, 16003
    Case 16003
        MsgBox "Menu dinâmico 3"
    Case 16004
        MsgBox "Sub item 1"
    Case 16005
        MsgBox "Sub item 2"
    Case 16006
        MsgBox "Sub item 3"
    Case Else
        'Não era um dos nossos menus
        MenuClicado = False
    End Select
End Function

Private Sub Form_Load()
    'Primeiro deve preparar o módulo!!!
    Module1.PreparaForm1 Me

    'Adiciona um separador ao menu 0 (primeiro menu)
    Module1.AdicionaSeparador 0

    'Adiciona três items ao menu 0 (primeiro menu)
    Module1.AdicionaItem 0, 16001, "Menu dinâmico 1"
    Module1.AdicionaItem 0, 16002, "Menu dinâmico 2"
    Module1.AdicionaItem 0, 16003, "Menu dinâmico 3"
    Module1.AdicionaSubMenu 0, "Menu dinâmico 4"
    Module1.AdicionaItemSub 0, 5, 16004, "Sub item 1"
    Module1.AdicionaItemSub 0, 5, 16005, "Sub item 2"
    Module1.AdicionaItemSub 0, 5, 16006, "Sub item 3"
End Sub

Code of Module1

Option Explicit

'API's do Windows para trabalhar com menus
Private Const MF_SEPARATOR As Long = &H800
Private Const MF_BYPOSITION As Long = &H400
Private Const MF_POPUP As Long = &H10
Private Declare Function GetMenu Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function AppendMenu Lib "user32.dll" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal uFlags As Long, ByVal uIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Declare Function RemoveMenu Lib "user32.dll" (ByVal hMenu As Long, ByVal uPosition As Long, ByVal uFlags As Long) As Long
Private Declare Function CreatePopupMenu Lib "user32.dll" () As Long

'API's do Windows para trabalhar com janelas e mensagens
Private Const WM_COMMAND As Long = &H111
Private Const GWL_WNDPROC As Long = -4
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'Endereço do WndProc antigo do Form
Private oldWndProc As Long
Private frmOriginal As Form1

Public Sub PreparaForm1(frm As Form1)
    Set frmOriginal = frm

    'Esse código todo tem que vir aqui em um módulo separado por causa
    'do operador AddressOf
    oldWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf WndProc)
End Sub

Public Sub AdicionaItem(ByVal indiceDoMenuPai As Long, ByVal id As Long, ByVal texto As String)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)

    AppendMenu menu, 0, id, texto
End Sub

Public Sub AdicionaItemSub(ByVal indiceDoMenuPai As Long, ByVal indiceDoSubMenu As Long, ByVal id As Long, ByVal texto As String)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)
    menu = GetSubMenu(menu, indiceDoSubMenu)

    AppendMenu menu, 0, id, texto
End Sub

Public Sub AdicionaSeparador(ByVal indiceDoMenuPai As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)

    AppendMenu menu, MF_SEPARATOR, 0, ""
End Sub

Public Sub AdicionaSeparadorSub(ByVal indiceDoMenuPai As Long, ByVal indiceDoSubMenu As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)
    menu = GetSubMenu(menu, indiceDoSubMenu)

    AppendMenu menu, MF_SEPARATOR, 0, ""
End Sub

Public Sub AdicionaSubMenu(ByVal indiceDoMenuPai As Long, ByVal texto As String)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)

    AppendMenu menu, MF_POPUP, CreatePopupMenu, texto
End Sub

Public Sub RemoveItemPorIndice(ByVal indiceDoMenuPai As Long, ByVal indiceDoItem As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)

    RemoveMenu menu, indiceDoItem, MF_BYPOSITION
End Sub

Public Sub RemoveItemPorIndiceSub(ByVal indiceDoMenuPai As Long, ByVal indiceDoSubMenu As Long, ByVal indiceDoItem As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)
    menu = GetSubMenu(menu, indiceDoSubMenu)

    RemoveMenu menu, indiceDoItem, MF_BYPOSITION
End Sub

Public Sub RemoveItemPorId(ByVal indiceDoMenuPai As Long, ByVal idDoItem As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)

    RemoveMenu menu, idDoItem, 0
End Sub

Public Sub RemoveItemPorIdSub(ByVal indiceDoMenuPai As Long, ByVal indiceDoSubMenu As Long, ByVal idDoItem As Long)
    Dim barraDeMenus As Long
    barraDeMenus = GetMenu(frmOriginal.hWnd)

    Dim menu As Long
    menu = GetSubMenu(barraDeMenus, indiceDoMenuPai)
    menu = GetSubMenu(menu, indiceDoSubMenu)

    RemoveMenu menu, idDoItem, 0
End Sub

Private Function WndProc(ByVal hWnd As Long, ByVal message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If message = WM_COMMAND Then
        If frmOriginal.MenuClicado(wParam And &HFFFF) = True Then
            'Quando um dos nossos menus foi clicado, apenas retorna 0,
            'e para a função por aqui
            WndProc = 0
            Exit Function
        End If
    End If
    'Chama o WndProc antigo do Form
    WndProc = CallWindowProc(oldWndProc, hWnd, message, wParam, lParam)
End Function