Меню с пользовательскими командами

Еще о создании пользовательских меню

Создание калькулятора

Листинг 3.81. Создание калькулятора

Sub SimpleCalculator()

Dim strExpr As String

' Ввод выражения

strExpr = InputBox("Что будем считать?")

' Подсчет и вывод результата

MsgBox strExpr & " = " & Application.Evaluate(strExpr)

End Sub

Листинг 3.82. Код в модуле ЭтаКнига

Sub Workbook_Open()

' Задание имени меню

strMenuName = "MyCommandBarName"

' Создание меню

CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

' Удаление меню перед закрытием книги

DeleteCustomMenu

End Sub

Листинг 3.83. Код в стандартном модуле

Public strMenuName As String ' Имя строки меню

Private cbrcBar As CommandBarControl

Sub CreateCustomMenu()

Dim cbrMenu As CommandBar

Dim cbrcMenu As CommandBarControl ' Выпадающее меню "Меню"

Dim cbrcSubMenu As CommandBarControl ' Выпадающее меню "Дополнительно"

' Если уже есть пользовательское меню, то оно удаляется

DeleteCustomMenu

' Создание меню вместо стандартного

Set cbrMenu = Application.CommandBars.Add(strMenuName, msoBarTop, _

True, True)

' Создание выпадающего меню с названием "Меню"

Set cbrcMenu = cbrMenu.Controls.Add(msoControlPopup,,,, True)

With cbrcMenu

.Caption = "&Меню"

End With

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "&Меню1"

.OnAction = "CallMenu1"

End With

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Меню2"

.OnAction = "CallMenu2"

End With

' Создание подменю первого уровня

Set cbrcSubMenu = cbrcMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "Подменю1"

.BeginGroup = True

End With

' Создание пункта меню

With cbrcMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Вкл/Выкл"

.OnAction = "MenuOnOff"

.Style = msoButtonIconAndCaption

.FaceId = 463

End With

' Создание пункта меню в подменю первого уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "Подменю1"

.OnAction = "CallSubMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 2950

.State = msoButtonDown

End With

' Cоздание пункта меню в подменю первого уровня (его состояние _

изменяется посредством пункта "Вкл/Выкл"), для чего сохраним ссылку _

на созданный пункт меню

Set cbrcBar = cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

With cbrcBar

.Caption = "Подменю2"

.OnAction = "CallSubMenu2"

' Сначала меню деактивировано

.Enabled = False

End With

' Создание подменю второго уровня

Set cbrcSubMenu = cbrcSubMenu.Controls.Add(Type:=msoControlPopup, _

Temporary:=True)

With cbrcSubMenu

.Caption = "ПодчПодменю1"

.BeginGroup = True

End With

' Cоздание пункта меню в подменю второго уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "ПослМеню1"

.OnAction = "CallLastMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 71

.State = msoButtonDown

End With

' Cоздание пункта меню в подменю второго уровня

With cbrcSubMenu.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

.Caption = "ПослМеню2"

.OnAction = "CallLastMenu2"

.Style = msoButtonIconAndCaption

.FaceId = 72

.Enabled = True

End With

' Отображение меню

cbrMenu.Visible = True

Set cbrcSubMenu = Nothing

Set cbrcMenu = Nothing

Set cbrMenu = Nothing

End Sub

Sub DeleteCustomMenu()

' Удаление строки меню

On Error Resume Next

Application.CommandBars(strMenuName).Delete

On Error GoTo 0

End Sub

Sub CallMenu1()

' Обработка вызова Меню1

MsgBox "Приветствует меню 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallMenu2()

' Обработка вызова Меню2

MsgBox "Приветствует меню 2!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallSubMenu1()

' Обработка вызова Подменю1

MsgBox "Приветствует подменю 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallSubMenu2()

' Обработка вызова Подменю2

MsgBox "Приветствует подменю 2!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallLastMenu1()

' Обработка вызова Последнего меню1

MsgBox "Приветствует последнее меню 1!", vbInformation, ThisWorkbook.Name

End Sub

Sub CallLastMenu2()

' Обработка вызова Последнего меню2

MsgBox "Приветствует последнее меню 2!", vbInformation, ThisWorkbook.Name

End Sub

Sub MenuOnOff()

' Активация или деактивация пункта "Меню-Подменю1-Подменю2"

cbrcBar.Enabled = Not cbrcBar.Enabled

End Sub

Дата добавления: 2015-06-25