Thursday, May 27, 2010

Create Dynamic commandbar (Menu Bar) in Excel :Easy to change

First add the "Microsoft windows common control 6.0"

Name the sheet as "Menus"
ABCDEFG
1LevelCaptionPosition/MacroDividerFaceIDControl TypeCheckbox
21My Menu1000
32&DayTRUE00
43&SundayModule3.cmd145300
53&MondayModule3.cmd219500
63&TuesdayModule3.cmd3212810
72&MonthTRUE00
83&JanModule3.cmd4320300
92&CarTRUE00
103&BMWModule3.cmd501

and call below module on workbook_open event 
Sub CreateMenu()
'   This sub should be executed when the workbook is opened.
'   NOTE: There is no error handling in this subroutine
    Dim MenuSheet As Worksheet
    Dim MenuObject As CommandBarPopup
    Dim MenuItem As Object
    Dim submenuitem As CommandBarButton
    'Dim submenuitem1 As CommandBarControl
    Dim Row As Integer
    Dim MenuLevel, NextLevel, PositionOrMacro, Caption, Divider, FaceId, cntType, Chkflg
''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Location for menu data
    Set MenuSheet = ThisWorkbook.Sheets("Menus")
''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Make sure the menus aren't duplicated
    Call DeleteMenu
   
'   Initialize the row counter
    Row = 2
'   Add the menus, menu items and submenu items using
'   data stored on MenuSheet
   
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        With MenuSheet
            MenuLevel = .Cells(Row, 1)
            Caption = .Cells(Row, 2)
            PositionOrMacro = .Cells(Row, 3)
            Divider = .Cells(Row, 4)
            FaceId = .Cells(Row, 5)
            NextLevel = .Cells(Row + 1, 1)
            cntType = .Cells(Row, 6)
            Chkflg = .Cells(Row, 6)
        End With
       
        Select Case MenuLevel
            Case 1 ' A Menu
'              Add the top-level menu to the Worksheet CommandBar
                Set MenuObject = Application.CommandBars(1). _
                    Controls.Add(Type:=msoControlPopup, _
                    Before:=PositionOrMacro, _
                    Temporary:=True)
                MenuObject.Caption = Caption
           
            Case 2 ' A Menu Item
                If NextLevel = 3 Then
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlPopup)
                Else
                    Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
                    MenuItem.OnAction = PositionOrMacro
                End If
                MenuItem.Caption = Caption
                If FaceId <> "" Then MenuItem.FaceId = FaceId
                If Divider Then MenuItem.BeginGroup = True
           
            Case 3 ' A SubMenu Item
                   
                    Select Case cntType
                   
                    Case 0
                        With MenuItem.Controls.Add(Type:=msoControlButton)
                                .Caption = Caption
                                .OnAction = PositionOrMacro
                                If Chkflg = 1 Then .State = msoButtonUp
                                If FaceId <> "" Then .FaceId = FaceId
                                If Divider Then .BeginGroup = True
                               
                        End With
                    Case 1
                        With MenuItem.Controls.Add(Type:=msoControlEdit)
                                .Caption = Caption
                                .OnAction = PositionOrMacro
                               
                                'If FaceId <> "" Then .FaceId = FaceId
                                If Divider Then .BeginGroup = True
                               
                       
                       
                        End With
                    Case 2
                   
                    End Select
               
               
                       
        End Select
       
        Row = Row + 1
    Loop
End Sub
Sub DeleteMenu()
'   This sub should be executed when the workbook is closed
'   Deletes the Menus
    Dim MenuSheet As Worksheet
    Dim Row As Integer
    Dim Caption As String
   
    On Error Resume Next
    Set MenuSheet = ThisWorkbook.Sheets("Menus")
    Row = 2
    Do Until IsEmpty(MenuSheet.Cells(Row, 1))
        If MenuSheet.Cells(Row, 1) = 1 Then
            Caption = MenuSheet.Cells(Row, 2)
            Application.CommandBars(1).Controls(Caption).Delete
        End If
        Row = Row + 1
    Loop
    On Error GoTo 0
End Sub