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

Добавление команды в меню Сервис

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

Создание раскрывающегося списка

Листинг 3.108. Создание панели со списком

Sub CreatePanel()

Dim i As Integer

On Error Resume Next

' Удаление одноименной панели (если есть)

CommandBars("Список месяцев").Delete

On Error GoTo 0

' Создание панели "Список месяцев"

With CommandBars.Add

.Name = "Список месяцев"

' Создание списка месяцев

With.Controls.Add(Type:=msoControlDropdown)

' Настройка (имя, макрос, стиль)

.Caption = "DateDD"

.OnAction = "SetMonth"

.Style = msoButtonAutomatic

' Добавление в список названий месяцев

For i = 1 To 12

.AddItem Format(DateSerial(1, i, 1), "mmmm")

Next i

' Выделение первого месяца

.ListIndex = 1

End With

' Показываем созданную панель

.Visible = True

End With

End Sub

Sub SetMonth()

' Перенос названия выделенного месяца в ячейку

On Error Resume Next

With CommandBars("Список месяцев").Controls("DateDD")

ActiveCell.Value =.List(.ListIndex)

End With

End Sub

Листинг 3.109. Новая команда в меню Сервис

Sub AddMenuItem()

Dim cbrpMenu As CommandBarPopup

' Удаление аналогичной команды (при ее наличии)

Call DeleteMenuItem

' Получение доступа к меню "Сервис"

Set cbrpMenu = CommandBars(1).FindControl(ID:=30007)

If cbrpMenu Is Nothing Then

' Не удалось получить доступ

MsgBox "Невозможно добавить элемент."

Exit Sub

Else

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

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

' Название команды

.Caption = "Очистить в&се, кроме формул"

' Значок

.FaceId = 348

' Сочетание клавиш (только надпись на кнопке)

.ShortcutText = "Ctrl+Shift+C"

' Сопоставленный макрос

.OnAction = "ExecuteCommand"

' Добавление разделителя перед командой

.BeginGroup = True

End With

End If

' Сопоставление с макросом сочетания клавиш Ctrl+Shift+C

Application.MacroOptions _

Macro:="ExecuteCommand", _

HasShortcutKey:=True, _

ShortcutKey:="C"

End Sub

Sub ExecuteCommand()

' Очистка содержимого всех ячеек (кроме формул)

On Error Resume Next

Cells.SpecialCells(xlCellTypeConstants, 23).ClearContents

End Sub

Sub DeleteMenuItem()

' Удаление команды из меню

On Error Resume Next

CommandBars(1).FindControl(ID:=30007). _

Controls("Очистить в&се, кроме формул").Delete

End Sub

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

Dim AppObject As New Class1

Sub AddCommand()

Dim cbrpBar As CommandBarPopup

' Удаление аналогичной команды (при ее наличии)

Call DeleteCommand

' Получение доступа к меню "Вид"

Set cbrpBar = CommandBars(1).FindControl(ID:=30004)

If cbrpBar Is Nothing Then

' Не удалось получить доступ к меню

MsgBox "Невозможно добавить элемент меню."

Exit Sub

Else

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

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

.Caption = "&Линии сетки"

.OnAction = "GhangeGridlinesState"

End With

End If

' Даем объекту AppObject обрабатывать события

Set AppObject.AppEvents = Application

End Sub

Sub DeleteCommand()

' Удаление каманды из меню (если она там есть)

On Error Resume Next

CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки").Delete

End Sub

Sub GhangeGridlinesState()

' Изменение состояния отображения линий сетки _

на противоположное (если нет - покажем, если есть - скроем)

If TypeName(ActiveSheet) = "Worksheet" Then

ActiveWindow.DisplayGridlines = _

Not ActiveWindow.DisplayGridlines

' Установка или снятие флажка в меню

Call CheckGridlines

End If

End Sub

Sub CheckGridlines()

Dim button As CommandBarButton

On Error Resume Next

' Поиск команды "Линии сетки" в меню "Вид"

Set button = CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки")

' Изменение состояния флажка на противоположное

If ActiveWindow.DisplayGridlines Then

' Установка

button.State = msoButtonDown

Else

' Снятие

button.State = msoButtonUp

End If

End Sub

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

Public WithEvents AppEvents As Application

' Обработка события активации листа

Sub AppEvents_SheetActivate(ByVal Sh As Object)

Call CheckGridlines

End Sub

' Обработка события активации книги

Sub AppEvents_WorkbookActivate(ByVal Wb As Excel.Workbook)

Call CheckGridlines

End Sub

' Обработка события активации окна

Sub AppEvents_WindowActivate _

(ByVal Wb As Workbook, ByVal Wn As Window)

Call CheckGridlines

End Sub

Глава 4. Трюки и эффекты с помощником

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