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

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 23.01.2019
• Размер: 1.35 Mb.
• Имя файла: Готовые макросы в VBA Excel, Миронов.doc
• Тип: Документы; #64865
• страница: 30 из 47

Отображение панели инструментов при определенном условии

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

Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

' Проверка условия отображения

If Union(Target, Range("A1:D5")).Address = _

Range("A1:D5").Address Then

' Условие выполнено - можно показывать панель

CommandBars("AutoSense").Visible = True

Else

' Условие не выполнено - панель нужно скрыть

CommandBars("AutoSense").Visible = False

End If

End Sub

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

Sub CreatePanel()

Dim cbrBar As CommandBar

Dim button As CommandBarButton

Dim i As Integer

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

On Error Resume Next

CommandBars("AutoSense").Delete

On Error GoTo 0

' Создание панели инструментов

Set cbrBar = CommandBars.Add

' Создание кнопок и их настройка

For i = 1 To 4

Set button = cbrBar.Controls.Add(msoControlButton)

With button

.OnAction = "ButtonClick" & i

.FaceId = i + 37

End With

Next i

cbrBar.Name = "AutoSense"

End Sub

Sub ButtonClick3()

' Перемещение вниз

On Error Resume Next

ActiveCell.Offset(1, 0).Activate

End Sub

Sub ButtonClick1()

' Перемещение вверх

On Error Resume Next

ActiveCell.Offset(-1, 0).Activate

End Sub

Sub ButtonClick2()

' Перемещение вправо

On Error Resume Next

ActiveCell.Offset(0, 1).Activate

End Sub

Sub ButtonClick4()

' Перемещение влево

On Error Resume Next

ActiveCell.Offset(0, -1).Activate

End Sub

Скрытие и отображение панелей инструментов

Листинг 3.94. Управление отображением панелей инструментов

Sub HidePanels()

Dim cbrBar As CommandBar

Dim intRow As Integer ' Номер текущей строки листа

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

Application.ScreenUpdating = False

' Подготовка к сохранению

Cells.Clear

' Скрытие видимых панелей и сохранение их названий

intRow = 1 ' Запись имен с первой строки

For Each cbrBar In CommandBars

If cbrBar.Type = msoBarTypeNormal Then

If cbrBar.Visible Then

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

Создать подсказку к моим кнопкам

' Cоздаем тулбар

Рublic Sub InitToolBar()

Dim cmdbarSM As CommandBar

Dim ctlNewBtn As CommandBarButton

Set cmdbarSM = CommandBars.Add(Name:="MyToolBar",

Position:=msoBarFloating, _

temporary:=True)

With cmdbarSM

' 1) Добавляем кнопку

Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

With ctlNewBtn

. FaceId = 26

.OnAction = "OnButton1_Click"

.TooltipText = "My tooltip message!"

End With

' 2) Добавляем ещё кнопку

Set ctlNewBtn = .Controls.Add(Type:=msoControlButton)

With ctlNewBtn

.FaceId = 44

.OnAction = "OnButton2_Click"

.TooltipText = "Another tooltip message!"

End With

.Visible = True

End With

End Sub

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

Листинг_3.95.'>Листинг 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