создаем раскрывающееся подменю
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
После того как данный код написан, в окне выбора макросов появятся макросы CreateMenu и DeleteMflenu – соответственно для создания и удаления пользовательского меню. Для удобства работы можно назначить каждому макросу кнопки.
Пользовательское меню, созданное на основании приведенных на рис. 3.34 исходных данных, показано на рис. 3.35.
Рис. 3.35. Пользовательское меню Выручка
Новое меню будет автоматически формироваться при каждом открытии рабочей книги и удаляться при ее закрытии.
Создание контекстного меню
В предыдущих разделах мы рассматривали различные способы формирования пользовательских меню, которые впоследствии отображались на вкладке Надстройки. Здесь же мы научимся создавать контекстное меню.
Итак, создадим пользовательское контекстное меню со следующими командами: Числовой формат, Выравнивание, Шрифт, Границы, Узор и Защита. С помощью этих команд на экран будет выводиться окно форматирования ячейки (вызываемое также нажатием комбинации клавиш Ctrl+1) с соответствующей открытой вкладкой. Созданное меню будет вызываться щелчком правой кнопки мыши на любой ячейке диапазона A2:D5.
Для решения поставленной задачи необходимо написать три кода: в модуле рабочего листа, в модуле Эта Книга и в стандартном модуле.
Код, который нужно поместить в модуль рабочего листа, выглядит следующим образом (листинг 3.94).
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.95.
Sub Workbook_Open()
' Создание контекстного меню при открытии книги
Call CreateCustomContextMenu
End Sub
Sub Workbook_BeforeClose(Cancel As Boolean)
' Удаление меню при закрытии книги
Call DeleteCustomContextMenu
End Sub
В стандартном модуле нужно написать самый большой код – его содержимое представлено в листинге 3.96.
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
Sub DeleteCustomContextMenu()
' Удаление меню
On Error Resume Next
CommandBars(«MyContextMenu»).Delete
End Sub
Sub ShowFormatNumber()
' Число
Application.Dialogs(xlDialogFormatNumber).Show
End Sub
Sub ShowFormatAlignment()
' Выравнивание
Application.Dialogs(xlDialogAlignment).Show
End Sub
Sub ShowFormatFont()
' Шрифт
Application.Dialogs(xlDialogFormatFont).Show
End Sub
Sub ShowFormatBorder()
' Граница
Application.Dialogs(xlDialogBorder).Show
End Sub
Sub ShowFormatPatterns()
' Вид (Узор)
Application.Dialogs(xlDialogPatterns).Show
End Sub
Sub ShowFormatProtection()
' Защита
Application.Dialogs(xlDialogCellProtection).Show
End Sub
После написания данного кода будут сформированы макросы создания пользовательского контекстного меню (CreateCustomContextMenu) и его удаления (DeleteCustomContextMenu), а также макросы, привязанные к командам созданного меню и предназначенные для вызова соответствующих вкладок диалогового окна Формат ячеек.
После выполнения макроса CreateCustomContextMenu будет сформировано контекстное меню, изображенное на рис. 3.36.
Рис. 3.36. Пользовательское контекстное меню
Это меню будет вызываться при щелчке правой кнопкой мыши на любой ячейке диапазона A2:D5. С помощью его команд осуществляется быстрый переход к соответствующей вкладке окна форматирования активной ячейки.
Просмотр содержимого папки
В процессе работы может возникать необходимость просмотра содержимого той или иной папки (например, для поиска требуемого файла). Чтобы ускорить данный процесс и не запускать для этой цели Проводник, рекомендуется воспользоваться макросом, код которого приведен в листинге 3.97.
' Объявление API-функции для отображения стандартного окна _
просмотра папок
Declare Function SHBrowseForFolder Lib «shell32.dll» _
Alias «SHBrowseForFolderA» (lpBrowseInfo As BROWSEINFO) As
Long
' Объявление API-функции для преобразования данных, возвращаемых _
функцией SHBrowseForFolder, в строку
Declare Function SHGetPathFromIDList Lib «shell32.dll» _
Alias «SHGetPathFromIDListA» (ByVal pidl As Long, ByVal _
pszPath As String) As Long
' Структура используется функцией SHBrowseForFolder
Type BROWSEINFO
hwndOwner As Long ' Родительское окно (для диалога)
pidlRoot As Long ' Корневая папка для просмотра
strDisplayName As String
strTitle As String ' Заголовок окна
ulFlags As Long ' Флаги для окна
' Следующие три параметра в VBA не используются
lpfn As Long
lParam As Long
iImage As Long
End Type
Sub BrowseFolder()
Dim strPath As String ' Папка, список файлов которой выводится
Dim strFile As String
Dim intRow As Long ' Текущая строка таблицы
' Выбор папки
strPath = dhBrowseForFolder()
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
' Оформление заголовка отчета
ActiveSheet.Cells.ClearContents
ActiveSheet.Cells(1, 1) = «Имя файла»
ActiveSheet.Cells(1, 2) = «Размер»
ActiveSheet.Cells(1, 3) = «Дата/время»
ActiveSheet.Range(«A1:C1»).Font.Bold = True
' Просмотр объектов в папке...
' Первый объект папки
strFile = Dir(strPath, 7)
intRow = 2
Do While strFile <> ""
' Запись в столбец "A" имени файла
ActiveSheet.Cells(intRow, 1) = strFile
' Запись в столбец "B" размера файла
ActiveSheet.Cells(intRow, 2) = FileLen(strPath & strFile)
' Запись в столбец "C" времени изменения файла
ActiveSheet.Cells(intRow, 3) = FileDateTime(strPath &
strFile)
' Следующий объект папки
strFile = Dir
intRow = intRow + 1
Loop
End Sub
Function dhBrowseForFolder() As String
Dim biBrowse As BROWSEINFO
Dim strPath As String
Dim lngResult As Long
Dim intLen As Integer
' Заполнение полей структуры BROWSEINFO