Индивидуальные очистные сооружения: К классу индивидуальных очистных сооружений относят сооружения, пропускная способность которых...
История развития хранилищ для нефти: Первые склады нефти появились в XVII веке. Они представляли собой землянные ямы-амбара глубиной 4…5 м...
Топ:
Особенности труда и отдыха в условиях низких температур: К работам при низких температурах на открытом воздухе и в не отапливаемых помещениях допускаются лица не моложе 18 лет, прошедшие...
Когда производится ограждение поезда, остановившегося на перегоне: Во всех случаях немедленно должно быть ограждено место препятствия для движения поездов на смежном пути двухпутного...
Организация стока поверхностных вод: Наибольшее количество влаги на земном шаре испаряется с поверхности морей и океанов...
Интересное:
Отражение на счетах бухгалтерского учета процесса приобретения: Процесс заготовления представляет систему экономических событий, включающих приобретение организацией у поставщиков сырья...
Инженерная защита территорий, зданий и сооружений от опасных геологических процессов: Изучение оползневых явлений, оценка устойчивости склонов и проектирование противооползневых сооружений — актуальнейшие задачи, стоящие перед отечественными...
Аура как энергетическое поле: многослойную ауру человека можно представить себе подобным...
Дисциплины:
2021-10-05 | 48 |
5.00
из
|
Заказать работу |
Листинг 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
Археология об основании Рима: Новые раскопки проясняют и такой острый дискуссионный вопрос, как дата самого возникновения Рима...
Опора деревянной одностоечной и способы укрепление угловых опор: Опоры ВЛ - конструкции, предназначенные для поддерживания проводов на необходимой высоте над землей, водой...
Папиллярные узоры пальцев рук - маркер спортивных способностей: дерматоглифические признаки формируются на 3-5 месяце беременности, не изменяются в течение жизни...
Общие условия выбора системы дренажа: Система дренажа выбирается в зависимости от характера защищаемого...
© cyberpedia.su 2017-2024 - Не является автором материалов. Исключительное право сохранено за автором текста.
Если вы не хотите, чтобы данный материал был у нас на сайте, перейдите по ссылке: Нарушение авторских прав. Мы поможем в написании вашей работы!