Вращающиеся автофигуры

Мигающая ячейка

Создание бегущей картинки

Листинг 3.77. Бегущая картинка

Sub MovingImage()

Dim i As Integer

Dim image As Object

' Создание изображения (в ячейке "A1")

With Range("A1")

' Формирование значения в ячейке:

' текст

.Value = "Привет!"

' полужирный шрифт

.Font.Bold = True

' цвет

.Font.Color = RGB(233, 133, 229)

' размер шрифта

.Font.Size = 16

' угол наклона

.Orientation = 30

' Отображение текста полностью

.EntireColumn.AutoFit

' Копирование в буфер обмена

.Copy

' Создание самостоятельного изображения (на основе _

скопированных в буфер обмена данных)

Set image = ActiveSheet.Pictures.Paste(Link:=False)

' Содержимое ячейки больше не нужно

.Clear

End With

' Задание начального положения изображения (левый верхний _

угол листа)

With image

.Top = 0

.Left = 0

End With

MsgBox "ПУСК!"

With image

' Перемещение изображения по диагонали

For i = 0 To 100

.Top = i

.Left = i

Next

' Удаление изображения

.Delete

End With

' Удаление ссылки на изображение

Set image = Nothing

End Sub

Листинг 3.78. Мигание ячейки

Sub BlinkingCell()

Static intCalls As Integer ' Счетчик количества миганий

' Если ячейка мигала менее 10 раз, то изменим _

в очередной раз ее цвет

If intCalls < 10 Then

intCalls = intCalls + 1

' Определение, какой цвет необходимо установить

If Range("A1").Interior.Color <> RGB(255, 0, 0) Then

' Цвет ячейки не красный, так что теперь назначим _

именно красный цвет

Range("A1").Interior.Color = RGB(255, 0, 0)

Else

' Назначим ячейке зеленый цвет

Range("A1").Interior.Color = RGB(0, 255, 0)

End If

' Эту процедуру необходимо вызвать через 5 секунд

Application.OnTime Now + TimeValue("00:00:05"), "BlinkingCell"

Else

' Хватит мигать

Range("A1").Interior.ColorIndex = xlNone

intCalls = 0

End If

End Sub

Листинг 3.79. Вращение автофигур

Sub RotatingAutoShapes()

Static fRunning As Boolean

' Проверка, выполняется ли уже этот макрос

If fRunning Then

' При повторном запуске останавливаем все запущенные макросы

fRunning = False

End

End If

' Укажем, что макрос запущен

fRunning = True

Dim cell As Range ' Рабочая ячейка

Dim intLeftBorder As Long ' Левая граница ячейки

Dim intRightBorder As Long ' Правая граница ячейки

Dim intTopBorder As Long ' Верхняя граница ячейки

Dim intBottomBorder As Long ' Нижняя граница ячейки

Dim alngVertSpeed(1 To 2) As Long ' Массивы со значениями

Dim alngHorzSpeed(1 To 2) As Long ' горизонтальной и вертикальной

' составляющих скоростей фигур

Dim ashShapes(1 To 2) As Shape ' Массив перемещаемых автофигур

Dim i As Integer

' Заполнение массива автофигур

Set ashShapes(1) = ActiveSheet.shapes(1)

Set ashShapes(2) = ActiveSheet.shapes(2)

' Заполнение массива скоростей:

' для первой фигуры

alngVertSpeed(1) = 3

alngHorzSpeed(1) = 3

' для второй фигуры

alngVertSpeed(2) = 4

alngHorzSpeed(2) = 4

' Получение границ рабочей ячейки

Set cell = Range("B2")

intLeftBorder = cell.Left

intRightBorder = cell.Left + cell.Width

intTopBorder = cell.Top

intBottomBorder = cell.Top + cell.Height

' Выполнение вращения и перемещения фигур

Do

' Изменение положения каждой автофигуры

For i = 1 To 2

With ashShapes(i)

' Контроль достижения правой границы ячейки

If.Left +.Width + alngHorzSpeed(i) > intRightBorder Then

' Корректировка положения

.Left = intRightBorder -.Width

' Изменение направления горизонтальной скорости _

на противоположное

alngHorzSpeed(i) = -alngHorzSpeed(i)

End If

' Контроль достижения левой границы ячейки

If.Left + alngHorzSpeed(i) < intLeftBorder Then

' Корректировка положения

.Left = intLeftBorder

' Изменение направления горизонтальной скорости _

на противоположное

alngHorzSpeed(i) = -alngHorzSpeed(i)

End If

' Контроль достижения нижней границы ячейки

If.Top +.Height + alngVertSpeed(i) > intBottomBorder Then

' Корректировка положения

.Top = intBottomBorder -.Height

' Изменение направления вертикальной скорости _

на противоположное

alngVertSpeed(i) = -alngVertSpeed(i)

End If

' Контроль достижения верхней границы ячейки

If.Top + alngVertSpeed(i) < intTopBorder Then

' Корректировка положения

.Top = intTopBorder

' Изменение направления вертикальной скорости _

на противоположное

alngVertSpeed(i) = -alngVertSpeed(i)

End If

' Перемещение автофигуры

.Left =.Left + alngHorzSpeed(i)

.Top =.Top + alngVertSpeed(i)

' Вращение автофигуры (изменение направления вращения _

происходит каждый раз при изменении направления _

вертикального перемещения)

.IncrementRotation alngVertSpeed(i)

' Даем Excel команду обработать пользовательский ввод

DoEvents

End With

Next

Loop

End Sub

Вызов таблицы цветов

Листинг 3.80. Отображение таблицы цветов

Sub ShowColorTable()

Dim intColor As Integer

' Формирование заголовка таблицы

Range("A1").Value = "Цвет"

Range("B1").Value = "Значение свойства ColorIndex"

' Вывод таблицы

Range("A2").Select

For intColor = 1 To 56

' Окрашиваем ячейку столбца "A" в текущий цвет

With ActiveCell.Interior

.ColorIndex = intColor

.Pattern = xlSolid

.PatternColorIndex = xlAutomatic

End With

' В ячейку столбца "B" вносим индекс текущего цвета

ActiveCell.Offset(0, 1).Value = intColor

' Переходим на следующую строку

ActiveCell.Offset(1, 0).Activate

Next

' Покажем ячейку "A1" (начало таблицы)

Range("A1").Select

ActiveWindow.ScrollRow = 1

End Sub

Дата добавления: 2015-06-25