Вызов окна настройки шрифта

Листинг 3.70.Окно настройки шрифта

Sub ShowFontDialog()

' Вызов стандартного окна настройки шрифта текущей ячейки

Application.Dialogs(xlDialogActiveCellFont).Show

EndSub

Вывод информации о текущем документе

Листинг 3.71.Информация о текущем документе

SubShowInfo()

DimiAsInteger

' Выводим имя файла рабочей книги

Range("A1") =ActiveWorkbook.Name

' Выводим имя текущего листа

Range("B1") =ActiveSheet.Name

' Выводим номера листов

For i = 1 To ActiveWorkbook.Sheets.Count

ActiveSheet.Cells(i, 3) = i

Next i

EndSub

Вывод результата расчетов в отдельном окне

Листинг 3.72.Окно с результатом расчетов

Sub ResultToWindow()

' Переходим на первый лист

Worksheets(1).Activate

' Заносим в ячейки данные

Range("A2") = 5

Range("A3") = "=A2+3"

' Выводим результат расчета

MsgBox Range("A3").Formula + " = " + str(Range("A3").Value)

End Sub

Вывод разрешения монитора

Листинг 3.73.Разрешение монитора

'Объявление API-функции

DeclareFunctionGetSystemMetricsLib"user32" _

(ByVal nIndex As Long) As Long

' Константы, которые передаются в функцию для определения _

горизонтального и вертикального размеров изображения

ConstSM_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

EndSub

Что открыто в данный момент?

Листинг 3.74.Открытые файлы

SubWorkBooksList()

DimbookAsObject

' Вывод имени каждой рабочей книги

For Each book In Workbooks

MsgBox (book.Name)

Next

EndSub

Листинг 3.75.«Перелистывание» книги

Sub SheetsOfBook()

Dim sheet As Object

' Отображение имен всех листов активной рабочей книги

For Each sheet In ActiveWorkbook.Sheets

MsgBox (sheet.Name)

Next

End Sub

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

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

DimintSpacesLeftAsInteger' Количество пробелов в начале строки

SubStart()

' Установка начального количества пробелов

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"

EndIf

EndSub

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

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

SubMovingImage()

Dim i As Integer

Dim image As Object

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

WithRange("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

EndWith

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

угол листа)

With image

.Top = 0

.Left = 0

End With

MsgBox "ПУСК!"

Withimage

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

For i = 0 To 100

.Top = i

.Left = i

Next

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

.Delete

EndWith

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

Set image = Nothing

End Sub