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

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

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

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