Добавление команды в меню Вид

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

Dim AppObject As New Class1

Sub AddCommand()

DimcbrpBarAsCommandBarPopup

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

CallDeleteCommand

' Получение доступа к меню "Вид"

Set cbrpBar = CommandBars(1).FindControl(ID:=30004)

IfcbrpBarIsNothingThen

' Не удалось получить доступ к меню

MsgBox"Невозможно добавить элемент меню."

ExitSub

Else

' Добавление команды

With cbrpBar.Controls.Add(Type:=msoControlButton)

.Caption = "&Линии сетки"

.OnAction = "GhangeGridlinesState"

End With

End If

' Даем объекту AppObject обрабатывать события

Set AppObject.AppEvents = Application

EndSub

SubDeleteCommand()

' Удаление каманды из меню (если она там есть)

On Error Resume Next

CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки").Delete

End Sub

SubGhangeGridlinesState()

' Изменение состояния отображения линий сетки _

на противоположное (если нет - покажем, если есть - скроем)

If TypeName(ActiveSheet) = "Worksheet" Then

ActiveWindow.DisplayGridlines = _

Not ActiveWindow.DisplayGridlines

' Установка или снятие флажка в меню

Call CheckGridlines

End If

End Sub

Sub CheckGridlines()

Dim button As CommandBarButton

OnErrorResumeNext

' Поиск команды "Линии сетки" в меню "Вид"

Set button = CommandBars(1).FindControl(ID:=30004). _

Controls("&Линии сетки")

' Изменение состояния флажка на противоположное

If ActiveWindow.DisplayGridlines Then

' Установка

button.State = msoButtonDown

Else

' Снятие

button.State = msoButtonUp

End If

End Sub

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

Public WithEvents AppEvents As Application

' Обработка события активации листа

Sub AppEvents_SheetActivate(ByVal Sh As Object)

Call CheckGridlines

End Sub

' Обработка события активации книги

Sub AppEvents_WorkbookActivate(ByVal Wb As Excel.Workbook)

Call CheckGridlines

End Sub

' Обработка события активации окна

Sub AppEvents_WindowActivate _

(ByVal Wb As Workbook, ByVal Wn As Window)

Call CheckGridlines

End Sub

Глава 4. Трюки и эффекты с помощником Мультфильм с помощником в главной роли

Листинг 4.1.«Танцующий» помощник

SubRunAssistantDance()

StaticintActionAsInteger

' Заставляем помощника выполнять действие (всего 16)

DoAssistantAction intAction

intAction = intAction + 1

If intAction < 16 Then

' Следующее действие через 3 секунды

Application.OnTime Time + TimeValue("00:00:3"), _

"RunAssistantDance"

End If

End Sub

Sub DoAssistantAction(intAction As Integer)

Dim astAssistant As Assistant

Set astAssistant = Application.Assistant

' Помещаем помощника в центр активного окна

astAssistant.Top = Application.ActiveWindow.Top _

+ Application.ActiveWindow.Height / 2

astAssistant.Left = Application.ActiveWindow.Left _

+ Application.ActiveWindow.Width / 2

' Показываем помощника

astAssistant.On = True

astAssistant.Visible = True

' Показываем заданное параметром intAction действие

Select Case intAction

Case 0

astAssistant.Animation = msoAnimationAppear

Case 1

astAssistant.Animation = msoAnimationCheckingSomething

Case 2

astAssistant.Animation = msoAnimationBeginSpeaking

Case 3

astAssistant.Animation = msoAnimationCharacterSuccessMajor

Case 4

astAssistant.Animation = msoAnimationEmptyTrash

Case 5

astAssistant.Animation = msoAnimationGestureDown

Case 5

astAssistant.Animation = msoAnimationGestureLeft

Case 6

astAssistant.Animation = msoAnimationGestureRight

Case 7

astAssistant.Animation = msoAnimationGestureUp

Case 8

astAssistant.Animation = msoAnimationGetArtsy

Case 9

astAssistant.Animation = msoAnimationGetAttentionMajor

Case 10

astAssistant.Animation = msoAnimationGetAttentionMinor

Case 11

astAssistant.Animation = msoAnimationGetTechy

Case 12

astAssistant.Animation = msoAnimationGetWizardy

Case 13

astAssistant.Animation = msoAnimationGoodbye

Case 14

astAssistant.Animation = msoAnimationGreeting

Case 15

astAssistant.Animation = msoAnimationDisappear

EndSelect

EndSub