Алексей Гладкий - Excel. Трюки и эффекты

cbrBar.Visible = False

Cells(intRow, 1) = cbrBar.Name

intRow = intRow + 1

End If

End If

Next

' Включение обновления экрана

Application.ScreenUpdating = True

End Sub

Sub ShowPanels()

Dim cell As Range ' Текущая ячейка листа

' Отключение обновления экрана

Application.ScreenUpdating = False

' Отображение скрытых панелей

On Error Resume Next

For Each cell In Range(«A:A»).SpecialCells( _

xlCellTypeConstants)

CommandBars(cell.Value).Visible = True

Next cell

' Включение обновления экрана

Application.ScreenUpdating = True

End Sub

После написания кода в окне выбора макросов появятся два макроса: Hide Panel s и ShowPanels. При выполнении первого макроса все используемые панели инструментов будут скрыты, а при выполнении второго они восстановятся на прежних местах. На рабочем листе Лист1 будет храниться перечень скрытых панелей. Для удобства работы можно назначить обоим макросам кнопки и поместить их на рабочий лист (но не на какую-нибудь панель инструментов).

Рассмотрим еще один способ создания пользовательского меню, которое будет отображаться на вкладке Надстройки. Характерной особенностью данного способа является то, что основой для формирования меню будут хранящиеся на рабочем листе данные.

В качестве исходных данных для создания пользовательского меню используем содержимое листа ЛистМеню (рис. 3.34).

Рис. 3.34. Исходные данные

Теперь в модуле ЭтаКнига напишем такой код (листинг 3.92).

Sub Workbook_Open()

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

Call CreateCustomMenu

End Sub

Sub Workbook_BeforeClose(Cancel As Boolean)

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

Call DeleteCustomMenu

End Sub

Следующий код (листинг 3.93) необходимо написать в стандартном модуле.

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))