Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7

• Название: Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
• Анкор: Информатика
• Дата: 16.05.2022
• Размер: 1.27 Mb.
• Имя файла: VBA_v_primerakh.doc
• Тип: Книга; #532661
• страница: 15 из 21

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

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

Sub ShowColorTable()

Dim intColor As Integer

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

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

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

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

Range("A2").Select

For intColor = 1 To 56

' Окрашиваем ячейку столбца "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

End Sub

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

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

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

Листинг 3.84. Создание пользовательского меню

Sub CreateMenu()

Dim cbrMenu As CommandBar

Dim cbrcNewMenu As CommandBarControl

' Удаление меню, если оно уже есть

Call DeleteMenu

' Добавление строки пользовательского меню

Set cbrMenu = CommandBars.Add(MenuBar:=True)

With cbrMenu

.Name = "Моя строка меню"

.Visible = True

End With

' Копирование стандартного меню "Файл"

CommandBars("Worksheet Menu Bar").FindControl(ID:=30002).Copy _

CommandBars("Моя строка меню")

' Добавление нового меню - "Дополнительно"

Set cbrcNewMenu = cbrMenu.Controls.Add(msoControlPopup)

cbrcNewMenu.Caption = "&Дополнительно"

' Добавление команды в новое меню

With cbrcNewMenu.Controls.Add(msoControlButton)

.Caption = "&Восстановить обычную строку меню"

.OnAction = "DeleteMenu"

End With

' Добавление команды в новое меню

With cbrcNewMenu.Controls.Add(Type:=msoControlButton)

.Caption = "&Справка"

End With

End Sub

Sub DeleteMenu()

' Пытаемся удалить меню (успешно, если оно ранее создано)

On Error Resume Next

CommandBars("Моя строка меню").Delete

On Error GoTo 0

End Sub