Главная страница
Навигация по странице:

  • Листинг 3.92.

  • Листинг 3.93.

  • Листинг 3.94.

  • Листинг 3.95.

  • Листинг 3.96.

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


    Скачать 1.35 Mb.
    НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
    Дата23.01.2019
    Размер1.35 Mb.
    Формат файлаdoc
    Имя файлаГотовые макросы в VBA Excel, Миронов.doc
    ТипДокументы
    #64865
    страница30 из 47
    1   ...   26   27   28   29   30   31   32   33   ...   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
    1   ...   26   27   28   29   30   31   32   33   ...   47


    написать администратору сайта