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

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

Создание панели со списком

Sub DeleteCustomContextMenu()

' Удаление меню

On Error Resume Next

CommandBars("MyContextMenu").Delete

End Sub

Sub ShowFormatNumber()

' Число

Application.Dialogs(xlDialogFormatNumber).Show

End Sub

Sub ShowFormatAlignment()

' Выравнивание

Application.Dialogs(xlDialogAlignment).Show

End Sub

Sub ShowFormatFont()

' Шрифт

Application.Dialogs(xlDialogFormatFont).Show

End Sub

Sub ShowFormatBorder()

' Граница

Application.Dialogs(xlDialogBorder).Show

End Sub

Sub ShowFormatPatterns()

' Вид (Узор)

Application.Dialogs(xlDialogPatterns).Show

End Sub

Sub ShowFormatProtection()

' Защита

Application.Dialogs(xlDialogCellProtection).Show

End Sub

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