2.8.Создание меню
2.8.5. Создание панели инструментов



Панель инструментов является   объктом CommandBar, который создается методом ADD семейства CommandBars, при этом в качестве значения параметра MenuBar  этого метода надо указать False.

 

Dim cb As CommandBar

Set cb = Application.CommandBars.Add(Name:=CormnandBarName,_

                                    Position:=msoBarTop,_

                                     MenuBar:=False, _

  Temporary:=True)

 

Элементами панели инструментов могут быть кнопки и раскрывающиеся списки. Продемонстрируем технику построения панели на простом примере. Панель будет иметь следующую структуру: раскрывающийся список Drop down menu, состоящий из трех элементов (Menulteml, Menultem2, Delete the User CommandBar) и разделительной линии, а также четырех кнопок. Выбор команды Delete the User CommandBar будет вызывать удаление созданной панели инструментов. С кнопками и другими командами раскрывающегося списка связана процеду­ра-заглушка, подтверждающая сделанный выбор.



 

В данном проекте код набирается в двух модулях: Этакнига и стандартном.

В модуле ЭтаКнига (листинг 2.7, а) имеются две процедуры. Первая из них обрабатывает событие open объекта workbook. Данная процедура вызывает процедуру СommandBarBulider, которая создает панель инструментов. Эта панель удалялась при закрытии книги. Для этого в коде обрабатывается событие BeforeClose объекта Workbook. В процедуре обработки данного собтия вызывается процедура CommandBarKiller, которая как раз и удаляет пользовательскую панель инструментов.

 

В модуле рабочего листа (листинг 2.7, б) объявлена постоянная commandBarName, задающая имя панели инструментов, и определены проце­дуры CommandBarBuilder и CommandBarKiller. Кроме того, в нем определе­ны процедура-заглушка DoMacro и вспомогательная процедура copyPictureFromFil,e, которая сначала вставляет рисунок из файла в рабо­чий лист, а затем в буфер обмена. Всем кнопкам назначены при помощи свойства ToolltipText всплывающие подсказки.

Для реализации данного проекта в книге должен существовать рабочий лист с именем Значки.


Листинг 2.7.а. Панель инструментов. Модуль ЭтаКнига

Option Explicit

 

Private Sub Workbook_Open()

CommandBarBuilder

End Sub

 

Private Sub Workbook_BeforeClose(Cancel As Boolean)

CommandBarKiller

End Sub

 

Листинг 2.7.б. Панель инструментов. Стандартный модуль.

Option Explicit

 

Const CommandBarName As String = "Custom CommandBar"

 

Sub CommandBarBuilder()

 Dim ws As Worksheet

 Set ws = Worksheets("Значки")

 Dim cb As CommandBar, cbDropDownMenu As CommandBarPopup

 Dim cbButton As CommandBarButton

 

‘Удаление панели инструментов, если она существует

CommandBarKiller

Set cb = Application.CommandBars.Add(_

 Name:=CommandBarName, Position:=msoBarTop,_

 MenuBar:=False, Temporary:=True)

 

Добавление выпадающего меню

Set cbDropDownMenu = cb.Controls.Add(Type:=msoControlPopup,_

 Temporary:=True)

cbDropDownMenu.Caption = "&Drop down menu"

 

‘Добавление 1 пункта в выпадающее меню

With cbDropDownMenu.Controls.Add(Type:=msoControlButton,_

 Temporary:=True)

.Caption = "&MenuItem1"

.Tag = "MenuItem1"

.OnAction = "DoMacro"

End With

 

Добавление 2 пункта в выпадающее меню

With cbDropDownMenu.Controls.Add(Type:=msoControlButton,_

 Temporary:=True)

.Caption = "MenuItem2"

.Tag = "MenuItem2"

.OnAction = "DoMacro"

End With

 

 

‘Добавление 3 пункта в выпадающее меню

With cbDropDownMenu.Controls.Add(Type:=msoControlButton,_

Temporary:=True)

.Caption = "&Delete the User CommandBar"

.OnAction = "CommandBarKiller"

.FaceId = 67 ' ID корзины

.Style = msoButtonIconAndCaption

.BeginGroup = True

End With

 

' Добавление кнопки с улыбающимся лицом

Set cbButton = cb.Controls.Add(Type:=msoControlButton,_

 Temporary:=True)

With cbButton

.Caption = "Button1"

.Tag = "Button1"

.Style = msoButtonIcon

.FaceId = 59 ' ID улыбающегося лица

.OnAction = "DoMacro"

.TooltipText = "Кнопка со встроенным рисунком"

End With

 

 

' Добавление кнопки со встроенным рисунком и надписью

Set cbButton = cb.Controls.Add(Type:=msoControlButton,_

 Temporary:=True)

With cbButton

.Caption = "Button2"

.Tag = "Button2"

.Style = msoButtonIconAndCaption

.OnAction = "DoMacro"

.FaceId = 225' ID замочка

.TooltipText = "кнопка со встроенным рисунком и надписью "

End With

 

' Добавление кнопки со значком из файла

Set cbButton = cb.Controls.Add(Type:=msoControlButton, _

Temporary:=True)

With cbButton

.Caption = "Button3"

.Tag = "Button3"

.Style = msoButtonIconAndCaption

.OnAction = "DoMacro"

 

' Вставка значка из файла

If CopyPictureFromFile(ws, ThisWorkbook.path & "\1.bmp") Then

.PasteFace

End If

.TooltipText = "Кнопка со значком из файла"

End With

 

' Добавление кнопки с текстом

Set cbButton = cb.Controls.Add(Type:=msoControlButton,_

 Temporary:=True)

With cbButton

.Caption = "&Button4"

.Tag = "Button4"

.OnAction = "DoMacro"

.Style = msoButtonCaption

.TooltipText = "Это просто кнопка"

End With

 

cb.Visible = True

Set cbButton = Nothing

Set cbDropDownMenu = Nothing

Set cb = Nothing

End Sub

 

Sub CommandBarKiller()

On Error Resume Next

Application.CommandBars(CommandBarName).Delete

On Error GoTo 0

End Sub

 

Sub DoMacro()

If Application.CommandBars.ActionControl Is Nothing Then

MsgBox "Нет ActionControl!"

Exit Sub

End If

 

Dim text As String

text = Application.CommandBars.ActionControl.Tag

If text = "MenuItem1" Then

MsgBox "Это MenuItem1"

ElseIf text = "MenuItem2" Then

MsgBox "Это Menuitem2!"

ElseIf text = "Button1" Then

MsgBox "Это Buttonl!"

ElseIf text = "Button2" Then

MsgBox "Это Button2!"

ElseIf text = "Button3" Then

MsgBox "Это Button3!"

ElseIf text = "Button4" Then

MsgBox "Это Button4!"

End If

End Sub

 

 Function CopyPictureFromFile(ws As Worksheet, _

SourceFile As String) As Boolean

If Len(Dir(SourceFile)) = 0 Then

MsgBox "Нет файла" & SourceFile

CopyPictureFromFile = False

Exit Function

End If

Dim pic As Object

On Error GoTo NoPicture

Set pic = ws.Pictures.Insert(SourceFile)

pic.CopyPicture xlScreen, xlPicture

pic.Delete

Set pic = Nothing

CopyPictureFromFile = True

Exit Function

NoPicture:

MsgBox "Something is wrong with " & SourceFile

CopyPictureFromFile = False

End Function



    
ПОИСК
МОЯ КНОПКА
Контакты
МБОУ "Лицей им.Атякшева"

628260 г. Югорск, ул. Ленина 24,
ХМАО-Югра, Тюменская область
Телефон: 8 (34675)2-48-30
Факс: 8 (34675)2-48-30



89222596815 nady_er@mail.ru
Карта
sample map