Готовые макросы в vba excel, Миронов Глава Макросы 9
 Скачать 1.35 Mb.
|
Отображение панели инструментов при определенном условииЛистинг 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 |