Вызов таблицы цветов

Листинг 3.80.Отображение таблицы цветов

Sub ShowColorTable()

Dim intColor As Integer

' Формирование заголовка таблицы

Range("A1").Value= "Цвет"

Range("B1").Value= "Значение свойстваColorIndex"

' Вывод таблицы

Range("A2").Select

ForintColor= 1To56

' Окрашиваем ячейку столбца "A" в текущий цвет

With ActiveCell.Interior

.ColorIndex = intColor

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

' В ячейку столбца "B" вносим индекс текущего цвета

ActiveCell.Offset(0, 1).Value=intColor

' Переходим на следующую строку

ActiveCell.Offset(1, 0).Activate

Next

' Покажем ячейку "A1" (начало таблицы)

Range("A1").Select

ActiveWindow.ScrollRow = 1

EndSub

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

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

Sub SimpleCalculator()

Dim strExpr As String

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

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

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

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

EndSub

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

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

SubWorkbook_Open()

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

strMenuName= "MyCommandBarName"

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

CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

DeleteCustomMenu

EndSub

Листинг 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"

EndWith

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

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

Temporary:=True)

.Caption = "Меню2"

.OnAction = "CallMenu2"

EndWith

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

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

EndWith

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

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

Temporary:=True)

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

.OnAction = "CallSubMenu1"

.Style = msoButtonIconAndCaption

.FaceId = 2950

.State = msoButtonDown

End With

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

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

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

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

Temporary:=True)

With cbrcBar

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

.OnAction= "CallSubMenu2"

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

.Enabled=False

EndWith

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

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

Temporary:=True)

With cbrcSubMenu

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

.BeginGroup=True

EndWith

' 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

EndSub

SubCallLastMenu1()

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

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

EndSub

SubCallLastMenu2()

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

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

EndSub

SubMenuOnOff()

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

cbrcBar.Enabled = Not cbrcBar.Enabled

End Sub