Чтобы быстро вывести на экран информацию об имени текущего файла, названии текущего рабочего листа и количестве листов в текущей рабочей книге, можно использовать макрос, код которого приведен в листинге 3.69.
Sub ShowInfo()
Dim i As Integer
' Выводим имя файла рабочей книги
Range(«A1») = ActiveWorkbook.Name
' Выводим имя текущего листа
Range(«B1») = ActiveSheet.Name
' Выводим номера листов
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveSheet.Cells(i, 3) = i
Next i
End Sub
Результат выполнения макроса представлен на рис. 3.22.
Рис. 3.22. Информация о текущем файле
В данном случае в ячейке А1 отображается имя текущего файла, в ячейке В1 – имя активного рабочего листа, а в столбце С – информация о количестве рабочих листов в текущей книге.
Вывод результата расчетов в отдельном окне
Выполнив несложный трюк, можно вывести результат расчетов, полученный с помощью формулы, в отдельном информационном окне. Для этого можно создавать самые разнообразные макросы (в зависимости от сложности расчета, содержимого ячеек и формул и т. д.). В листинге 3.70 приведен пример одного из таких макросов.
Sub ResultToWindow()
' Переходим на первый лист
Worksheets(1).Activate
' Заносим в ячейки данные
Range(«A2») = 5
Range(«A3») = «=A2+3»
' Выводим результат расчета
MsgBox Range(«A3»).Formula + " = " + str(Range(«A3»).Value)
End Sub
Результат выполнения данного макроса показан на рис. 3.23.
Рис. 3.23. Формула и результат
Кроме того, после выполнения макроса в ячейке А2 появится значение 5, а в ячейке A3 – 8.
Вывод разрешения монитора
Разрешение монитора просматривается и редактируется в окне свойств экрана (Пуск → Настройка → Панель управления → Экран → Параметры). Однако для просмотра разрешения можно написать соответствующий макрос (листинг 3.71). Чтобы определить разрешение монитора, следует использовать функцию Windows API GetSystemMetrics. В качестве единственного параметра она принимает номер системной настройки, значение которой необходимо узнать (в данном случае 0 – это ширина изображения, 1 – высота). Функция GetSystemMetrics возвращает численное значение запрашиваемого параметра.
' Объявление API-функции
Declare Function GetSystemMetrics Lib «user32» _
(ByVal nIndex As Long) As Long
' Константы, которые передаются в функцию для определения _
горизонтального и вертикального размеров изображения
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Sub GetMonitorResolution()
Dim lngHorzRes As Long
Dim lngVertRes As Long
' Получение ширины и высоты изображения на мониторе
lngHorzRes = GetSystemMetrics(SM_CXSCREEN)
lngVertRes = GetSystemMetrics(SM_CYSCREEN)
' Отображение сообщения
MsgBox "Текущее разрешение: " & lngHorzRes & "x" & lngVertRes
End Sub
После того как запущен макрос (в окне выбора макросов он будет называться GetMonitorResolution), на экране отобразится окно, в котором будет показано текущее разрешение монитора.
Что открыто в данный момент?
При работе с большим количеством рабочих книг иногда возникает необходимость быстро узнать, какие из них открыты в данный момент. Решить эту задачу поможет следующий макрос (листинг 3.72).
Sub WorkBooksList()
Dim book As Object
' Вывод имени каждой рабочей книги
For Each book In Workbooks
MsgBox (book.Name)
Next
End Sub
После выполнения данного макроса откроется окно с именем текущей рабочей книги. После нажатия в данном окне кнопки ОК в нем будет указано имя другой открытой книги, затем после нажатия ОК – следующей и т. д. Таким образом можно быстро просмотреть названия всех открытых рабочих книг.
Если книга содержит большое количество рабочих листов, то быстро просмотреть их названия можно с помощью следующего макроса (листинг 3.73). Этот макрос отображает названия всех листов текущей рабочей книги.
Sub SheetsOfBook()
Dim sheet As Object
' Отображение имен всех листов активной рабочей книги
For Each sheet In ActiveWorkbook.Sheets
MsgBox (sheet.Name)
Next
End Sub
После запуска макроса на экране отобразится такое же окно, как при выполнении предыдущего макроса. В нем будет указано название первого рабочего листа текущей книги, а затем, после каждого нажатия кнопки ОК, – названия последующих листов.
Создание бегущей строки
Можно ли в Excel создать бегущую строку? Да, можно, и поможет нам в этом код, приведенный в листинге 3.74.
Dim intSpacesLeft As Integer ' Количество пробелов в начале
строки
Sub Start()
' Установка начального количества пробелов
intSpacesLeft = 10
' Первый вызов функции бегущей строки
MovingString
End Sub
Sub MovingString()
If intSpacesLeft >= 0 Then
' Отображение строки
Range(«A1»).Value = Space(intSpacesLeft) & «Привет!»
intSpacesLeft = intSpacesLeft – 1
' Указывем Excel, что данную процедуру нужно вызвать через _
1 секунду
Application.OnTime Now + TimeValue(«00:00:01»),
«MovingString»
End If
End Sub
После запуска макроса Start в ячейке Al будет отображаться бегущая строка с текстом Привет!.
Мигающая ячейка
Рассмотрим достаточно интересный трюк, с помощью которого можно заставить мигать (то есть попеременно изменять цвета) любую ячейку в течение некоторого промежутка времени.
Предположим, что нам необходима ячейка, которая 10 раз каждые 5 секунд будет изменять цвет фона с красного на зеленый. Для решения этой задачи воспользуемся следующим макросом (листинг 3.75).
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
После запуска макроса BlinkingCell будет мигать ячейка Al. Путем внесения соответствующих изменений в приведенный макрос можно регулировать продолжительность цикла и изменять цвета фона по своему усмотрению.
Вращающиеся автофигуры
Можно ли заставить автофигуры вращаться? Оказывается, можно, и это вовсе не так сложно, как кажется на первый взгляд. В этом разделе мы рассмотрим, каким образом можно заставить перемещаться с одновременным вращением сразу две автофигуры.
Для реализации данного трюка нам нужно в первую очередь написать макрос, код которого представлен в листинге 3.76 (этот код нужно поместить в стандартный модуль редактора VBA).
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
' Контроль достижения левой границы ячейки