Создание меню на основе данных рабочего листа

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

Sub Workbook_Open()

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

Call CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

Call DeleteCustomMenu

End Sub

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

Sub CreateMenu()

Dim sheet As Worksheet     ' Лист с описанием меню

Dim intRow As Integer      ' Считываемая строка

Dim cbrpBar As CommandBarPopup ' Выпадающее меню

Dim objNewItem As Object   ' Элемент меню cbrpBar

Dim objNewSubItem As Object ' Элемент подменю objNewItem

Dim intMenuLevel As Integer ' Уровень вложенности пункта меню

Dim strCaption As String   ' Название пункта меню

Dim strAction As String    ' Макрос пункта меню

Dim fIsDevider As Boolean  ' Нужен разделитель

Dim intNextLevel As Integer ' Уровень вложенности следующего _

                               пункта меню

Dim strFaceID As String    ' Номер значка пункта меню

 

' Расположение данных для меню

Set sheet = ThisWorkbook.Sheets("ЛистМеню")

 

' Удаление одноименного меню (при его наличии)

Call DeleteMenu

 

' Данные считываем со второй строки

intRow = 2

' Добавление меню

Do Until IsEmpty(sheet.Cells(intRow, 1))

' Считываем информацию о пункте меню

With sheet

    ' Уровень вложенности

    intMenuLevel =.Cells(intRow, 1)

    ' Название

    strCaption =.Cells(intRow, 2)

    ' Название макроса для меню

    strAction =.Cells(intRow, 3)

      ' Нужен ли разделитель перед меню?

    fIsDevider =.Cells(intRow, 4)

    ' Номер стандартного значка (если значок нужен)

    strFaceID =.Cells(intRow, 5)

    ' Уровень вложенности следующего меню

    intNextLevel =.Cells(intRow + 1, 1)

End With

' Создаем меню в зависимости от уровня его вложенности

Select Case intMenuLevel

    Case 1

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

       Set cbrpBar = Application.CommandBars(1). _

        Controls.Add(Type:=msoControlPopup, _

        Before:=strAction, _

        Temporary:=True)

       cbrpBar.Caption = strCaption

    Case 2

       ' Создаем элемент меню

       If intNextLevel = 3 Then

          ' Следующий элемент вложен в создаваемый, то есть _

           создаем раскрывающееся подменю

          Set objNewItem = _

           cbrpBar.Controls.Add(Type:=msoControlPopup)

       Else

          ' Создаем команду меню

          Set objNewItem = _

           cbrpBar.Controls.Add(Type:=msoControlButton)

          objNewItem.OnAction = strAction

       End If

       ' Установка названия нового пункта меню

       objNewItem.Caption = strCaption

       ' Установка значка нового пункта меню (если нужно)

       If strFaceID <> "" Then

          objNewItem.FaceId = strFaceID

       End If

       ' Если нужно, то добавим разделитель

       If fIsDevider Then

          objNewItem.BeginGroup = True

       End If

    Case 3

       ' Создание элемента подменю

       Set objNewSubItem = _

        objNewItem.Controls.Add(Type:=msoControlButton)

       ' Установка его названия

       objNewSubItem.Caption = strCaption

       ' Назначение макроса (или команды)

       objNewSubItem.OnAction = strAction

       ' Установка значка (если нужно)

       If strFaceID <> "" Then

         objNewSubItem.FaceId = strFaceID

       End If

       ' Если нужно, то добавим разделитель

       If fIsDevider Then

          objNewSubItem.BeginGroup = True

       End If

End Select

' Переход на следующую строку таблицы

intRow = intRow + 1

Loop

End Sub

 

Sub DeleteMenu()

Dim sheet As Worksheet ' Лист с описанием меню

Dim intRow As Integer ' Считываемая строка

Dim strCaption As String ' Название меню

 

Set sheet = ThisWorkbook.Sheets("ЛистМеню")

' Данные начинаются со второй строки

intRow = 2

' Считываем данные, пока есть значения в столбце "A", _

и удаляем созданные ранее меню (с уровнем вложенности 1)

On Error Resume Next

Do Until IsEmpty(sheet.Cells(intRow, 1))

If sheet.Cells(intRow, 1) = 1 Then

    strCaption = sheet.Cells(intRow, 2)

     Application.CommandBars(1).Controls(strCaption).Delete

End If

intRow = intRow + 1

Loop

On Error GoTo 0

End Sub

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

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