Создание контекстного меню

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

Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, _

Cancel As Boolean)

' Проверка, попадает ли выделенная ячейка в диапазон

If Union(Target.Range("A1"), Range("A2:D5")).Address = _

Range("A2:D5").Address Then

' Показываем свое контекстное меню

CommandBars("MyContextMenu").ShowPopup

Cancel = True

End If

End Sub

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

Sub Workbook_Open()

' Создание контекстного меню при открытии книги

Call CreateCustomContextMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

Call DeleteCustomContextMenu

End Sub

Код в стандартном модуле

Sub CreateCustomContextMenu()

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

Call DeleteCustomContextMenu

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

With CommandBars.Add("MyContextMenu", msoBarPopup, , True).Controls

' Создание и настройка кнопок меню

' Кнопка "Числовой формат"

With .Add(msoControlButton)

.Caption = "&Числовой формат..."

.OnAction = "ShowFormatNumber"

.FaceId = 1554

End With

' Кнопка "Выравнивание"

With .Add(msoControlButton)

.Caption = "&Выравнивание..."

.OnAction = "ShowFormatAlignment"

.FaceId = 217

End With

' Кнопка "Шрифт"

With .Add(msoControlButton)

.Caption = "&Шрифт..."

.OnAction = "ShowFormatFont"

.FaceId = 291

End With

' Кнопка "Границы"

With .Add(msoControlButton)

.Caption = "&Границы..."

.OnAction = "ShowFormatBorder"

.FaceId = 149

.BeginGroup = True

End With

' Кнопка "Узор"

With .Add(msoControlButton)

.Caption = "&Узор..."

.OnAction = "ShowFormatPatterns"

.FaceId = 1550

End With

' Кнопка "Защита"

With .Add(msoControlButton)

.Caption = "&Защита..."

.OnAction = "ShowFormatProtection"

.FaceId = 2654

End With

End With

End Sub

Блокировка контекстного меню

Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

Static intCount As Integer ' Счетчик нажатий кнопки мыши

Dim x As Integer, y As Integer

' Блокировать обработку щелчка правой кнопкой мыши

Cancel = True

' Отображение текстового поля с количеством щелчков правой _

кнопкой мыши

x = Target.Left

y = Target.Top

intCount = intCount + 1

ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _

x, y, 35, 20).TextFrame.Characters.Text = intCount

End Sub

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

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