Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 31 из 47

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

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

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

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