VERSION  1 . 0  CLASS
BEGIN
  MultiUse = - 1   'True
END
Attribute VB_Name = "LbMenu"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Option Compare Database
Option Explicit

'LbMenu
'Name           Type    Description
'CreateTop      Function    Create a command bar on top
'CreateLeft     Function    Create a command bar on left
'CreateRight    Function    Create a command bar on right
'CreateBottom   Function    Create a command bar on bottom
'CreateMenu     Function    Create a main menu
'CreateContext  Function    Create a context menu
'Visible        Property    Hide/show a command bar
'MenuName       Property    Menu name
'Delete         Sub         Delete id-th item from a command bar or the command bar itself (id=0)
'Enable         Property    Enable/disable id-th item of a command bar or the command bar itself (id=0)
'BarType        Function    Return a type of a "id"-th command bar(id=0 - current object)
'JumpOut        Sub         Show a popup menu
'AddButton      Function    Add a button
'AddItem        Function    Add a new menu item
'AddSubmenu     Function    Add a new submenu to the main menu
'AddSubitem     Function    Add a new item to the submenu
'AddTextbox     Function    Add a textbox
'AddListbox     Function    Add a listbox
'AddCombobox    Function    Add a combobox
'IntoList       Function    Insert element into list/combobox list
'Choice         Function    Number of the chosen item in the list/combo box or -1
'Text           Property    Text in the i-th control
'ChangeSize     Sub         Change a size of control

Private m_menu As CommandBar

Private Sub Class_Initialize()
    Set m_menu = Nothing
End Sub
Private Sub Class_Terminate()
    FreeBar
'    StateRestore
End Sub
'Delete the command bar
Private Sub FreeBar()
    On Error Resume Next
    Application.CommandBars(m_menu.Index).Delete
    Set m_menu = Nothing
End Sub
'Create a command bar
Private Function Create(name As String, where As Integer) As Integer
    Dim b As Boolean
    Create =  0 
    On Error GoTo smthng
    If Not m_menu Is Nothing Then FreeBar
    b = where <> msoBarPopup
    Set m_menu = Application.CommandBars.Add(name, where, b, True)
    Create = Application.CommandBars.item(name).Index
    If b Then m_menu.Visible = b
smthng:
    Select Case Err.Number
    Case  0 
    Case  5 
        Application.CommandBars(name).Delete
        Resume
    Case Else
        MsgBox Err.Description, , "Create " & Err.Number
    End Select
End Function
Public Function CreateTop(name As String) As Integer
    CreateTop = Create(name, msoBarTop)
End Function
Public Function CreateLeft(name As String) As Integer
    CreateLeft = Create(name, msoBarLeft)
End Function
Public Function CreateRight(name As String) As Integer
    CreateRight = Create(name, msoBarRight)
End Function
Public Function CreateBottom(name As String) As Integer
    CreateBottom = Create(name, msoBarBottom)
End Function
Public Function CreateMenu(name As String) As Integer
    CreateMenu = Create(name, msoBarFloating)
End Function
Public Function CreateContext(name As String) As Integer
    CreateContext = Create(name, msoBarPopup)
End Function
'Hide/show a command bar
Public Property Get Visible() As Boolean
    Visible = m_menu.Visible
End Property
Public Property Let Visible(v As Boolean)
    m_menu.Visible = v
End Property
'Menu name
Public Property Get MenuName() As String
    MenuName = m_menu.name
End Property
Public Property Let MenuName(ByVal vNewValue As String)
    m_menu.name = vNewValue
End Property
'Delete id-th item from a command bar or the command bar itself (id=0)
Public Sub Delete(Optional id As Integer =  0 )
    On Error Resume Next
    If id >  0  Then
        m_menu.Controls(id).Delete
    Else
        FreeBar
    End If
End Sub
'Enable/disable id-th item of a command bar or the command bar itself (id=0)
Public Property Get Enable(id As Integer) As Boolean
    Enable = False
    On Error GoTo wrong
    If id =  0  Then
        Enable = m_menu.Enabled
    Else
        Enable = m_menu.Controls(id).Enabled
    End If
wrong:
End Property
Public Property Let Enable(id As Integer, ByVal vNewValue As Boolean)
    On Error GoTo wrong
    If id =  0  Then
        m_menu.Enabled = vNewValue
    Else
        m_menu.Controls(id).Enabled = vNewValue
    End If
wrong:
End Property
'Return a type of a "id"-th command bar(id=0 - current object):
'   msoBarTypeNormal = 0   toolbar,
'   msoBarTypeMenuBar = 1  menu,
'   msoBarTypePopup = 2    context menu
Public Function BarType(Optional id As Integer =  0 ) As Integer
    On Error GoTo NoBar
    If id =  0  Then
        BarType = m_menu.Type
    Else
        BarType = Application.CommandBars(id).Type
    End If
    Exit Function
NoBar:
    BarType = - 1 
End Function
'Show a popup menu. In Worksheet_BeforeRightClick must stay:
'    [].JumpOut
'    Cancel = True
Public Sub JumpOut()
    If BarType = msoBarTypePopup Then m_menu.ShowPopup
End Sub
'Add a control to the command bar
Private Function AddControl(capt As String, t As Integer) As Integer
    Dim newit As CommandBarControl
    AddControl =  0 
    On Error GoTo wrong
    Select Case t
    Case msoControlButton                       '???
        Set newit = m_menu.Controls.Add(t)
    Case msoControlEdit                         'Textbox
        Set newit = m_menu.Controls.Add(t)
    Case msoControlDropdown                     'Listbox
        Set newit = m_menu.Controls.Add(t)
    Case msoControlComboBox                     'ComboBox
        Set newit = m_menu.Controls.Add(t)
    Case msoControlPopup                        'Item
        Set newit = m_menu.Controls.Add(t)
    Case Else
        MsgBox "Wrong type of control"
    End Select
    newit.Caption = capt
    newit.Visible = True
    AddControl = newit.Index
    Exit Function
wrong:
    Select Case Err.Number
    Case  91 
        Exit Function
    Case Else
        MsgBox Err.Description, , "AddControl " & Err.Number
    End Select
End Function
'Add a new button with text: capt - caption, proc - procedure name to execute
Public Function AddButton(capt As String, proc As String) As Integer
    AddButton = AddControl(capt, msoControlButton)
    If AddButton <>  0  Then
        m_menu.Controls(AddButton).Style = msoButtonCaption
        m_menu.Controls(AddButton).OnAction = proc
    End If
End Function
'Add a new menu item: capt - caption, proc - name of a procedure to execute
Public Function AddItem(capt As String, proc As String) As Integer
    AddItem = AddControl(capt, msoControlPopup)
    If AddItem <>  0  Then m_menu.Controls(AddItem).OnAction = proc
End Function
'Add a new submenu: capt - caption
Public Function AddSubmenu(capt As String) As Integer
    AddSubmenu = AddControl(capt, msoControlPopup)
End Function
'Nesting level
Private Function RealSize(item As Variant) As Integer
    RealSize = - 1 
    On Error GoTo wrong
    RealSize = UBound(item)                     'dimension
    While item(RealSize) <=  0  And RealSize >  0   'unused elements
        RealSize = RealSize -  1 
    Wend
wrong:
End Function
'Submenu item
Private Function RealControl(item As Variant) As CommandBarControl
    Dim n As Integer, k As Integer
    On Error GoTo wrong
    n = RealSize(item)
    If n >  0  Then
        For k =  1  To n                              'search a submenu
            If k =  1  Then
                Set RealControl = m_menu.Controls(item( 1 ))
            Else
                If item(k) >  0  Then Set RealControl = RealControl.Controls(item(k))
            End If
        Next k
    Else
        Set RealControl = Nothing
    End If
    Exit Function
wrong:
    Select Case Err.Number
    Case  5                   'wrong type
        Set RealControl = Nothing
    Case  9                   'wrong item number
        Set RealControl = Nothing
    Case Else
        MsgBox Err.Description, , "AddSubitem " & Err.Number
    End Select
End Function
'Add a new item to the submenu:
'item - submenu number: item(0) - command bar index (not used),
'                       item(1) - submenu index,
'                       item(2) - sub-submenu index, etc
'capt - caption
'proc - name of a procedure to execute
Public Function AddSubitem(item As Variant, capt As String, _
                        Optional proc As String = "", Optional tag As String = "") As Integer
    Dim itm As CommandBarControl, newit As CommandBarControl
    AddSubitem = - 1 
    On Error GoTo wrong
    Set itm = RealControl(item)
    If itm.Type = msoControlPopup Then
        If proc = "" Then
            Set newit = itm.Controls.Add(msoControlPopup)
        Else
            Set newit = itm.Controls.Add(msoControlButton)
            newit.Style = msoButtonCaption
            newit.OnAction = proc
        End If
        newit.Caption = capt
        newit.tag = tag
        newit.Visible = True
        AddSubitem = newit.Index
    End If
    Exit Function
wrong:
    Select Case Err.Number
    Case  5                   'wrong type
        Exit Function
    Case  9                   'wrong item number
        Exit Function
    Case Else
        MsgBox Err.Description, , "AddSubitem " & Err.Number
    End Select
End Function
'Add a new textbox: capt - caption, txt - initial text
Public Function AddTextbox(capt As String, Optional txt As String = "") As Integer
    AddTextbox = AddControl(capt, msoControlEdit)
    If AddTextbox <>  0  Then m_menu.Controls(AddTextbox).Text = txt
End Function
'Add a new listbox: capt - caption, list - set of strings
Public Function AddListbox(capt As String, Optional list As Variant =  0 ) As Integer
    Dim i As Integer
    AddListbox = AddControl(capt, msoControlDropdown)
    If TypeName(list) = "String()" And AddListbox <>  0  Then
        For i = LBound(list) To UBound(list)
            IntoList AddListbox, list(i)
        Next i
    End If
End Function
'Add a new combobox: capt - caption, list - set of strings
Public Function AddCombobox(capt As String, Optional list As Variant =  0 ) As Integer
    AddCombobox = AddControl(capt, msoControlComboBox)
    Dim i As Integer
    If TypeName(list) = "String()" And AddCombobox <>  0  Then
        For i = LBound(list) To UBound(list)
            IntoList AddCombobox, list(i)
        Next i
    End If
End Function
'Insert element "s" into list/combobox list. Return a list size or -1
Public Function IntoList(k As Integer, s As Variant) As Integer
    On Error Resume Next
    IntoList = - 1 
    If TypeName(s) = "String" And _
        (m_menu.Controls(k).Type = msoControlDropdown Or _
        m_menu.Controls(k).Type = msoControlComboBox) Then _
        m_menu.Controls(k).AddItem s
    IntoList = m_menu.Controls(k).ListCount
End Function
'Number of the chosen item in the list/combo box or -1
Public Function Choice(n As Integer) As Integer
    If m_menu.Controls(n).Type = msoControlDropdown _
    Or m_menu.Controls(n).Type = msoControlComboBox Then
        Choice = m_menu.Controls(n).ListIndex
    Else
        Choice = - 1 
    End If
End Function
'text in the i-th control
Public Property Get Text(i As Integer) As String
    Text = ""
    On Error Resume Next
    Text = m_menu.Controls(i).Text
End Property
Public Property Let Text(i As Integer, ByVal vNewValue As String)
    On Error Resume Next
    m_menu.Controls(i).Text = vNewValue
End Property
'Change a size of control in "mal" times
Public Sub ChangeSize(k As Variant, mal As Double)
    Dim ctl As CommandBarControl, i As Integer
    On Error Resume Next
    Select Case TypeName(k)                                         'search a submenu
    Case "Integer"
        Set ctl = m_menu.Controls(k)
    Case "Long"
        Set ctl = m_menu.Controls(k)
    Case "Integer()"
        Set ctl = RealControl(k)
    Case Else
        Exit Sub
    End Select
    ctl.width = CInt(ctl.width * mal)
End Sub