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

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