Главная страница
Навигация по странице:

  • Листинг 3.98.

  • Листинг 3.110.

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


    Скачать 1.35 Mb.
    НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
    Дата23.01.2019
    Размер1.35 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel, Миронов.doc
    ТипДокументы
    #64865
    страница31 из 47
    1   ...   27   28   29   30   31   32   33   34   ...   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
    1   ...   27   28   29   30   31   32   33   34   ...   47


    написать администратору сайта