Готовые макросы в vba excel, Миронов Глава Макросы 9

• Название: Готовые макросы в vba excel, Миронов Глава Макросы 9
• Дата: 06.02.2018
• Размер: 1.35 Mb.
• Имя файла: 33980_7d1642e70814394f108d07a8a2edd23e.doc
• Тип: Документы; #35930
• страница: 41 из 47

Создать обложку DVD

Sub Обложка_DVD()

On Error Resume Next

Sheets("Обложка").Select

If Err > 0 Then GoTo 10 Else MsgBox ("Такой лист уже присутствует в книге..."): Exit Sub

10:

Sheets.Add.Name = "Обложка" ' создаем новый лист в текущей книге с именем "Обложка"

Sheets("Обложка").Range("A1").Select ' становимся в ячейку А1

Application.Dialogs(xlDialogInsertPicture).Show 'вызываем диологовое окно "Вставка рисунка из файла"

Selection.ShapeRange.LockAspectRatio = msoFalse '

' Selection.ShapeRange.Height = 530.25 ' подгоняем размеры под размеры коробки

' Selection.ShapeRange.Width = 726# '

Selection.ShapeRange.Height = 530.2 ' подгоняем размеры под размеры коробки

Selection.ShapeRange.Width = 724# '

Selection.ShapeRange.Rotation = 0# '

Selection.Locked = False '

With ActiveSheet.PageSetup ' разносим поля листа на максимальные расстояния

.LeftMargin = Application.InchesToPoints(0.17)

.RightMargin = Application.InchesToPoints(0.17)

.TopMargin = Application.InchesToPoints(0.27)

.BottomMargin = Application.InchesToPoints(0.27)

.HeaderMargin = Application.InchesToPoints(0.17)

.FooterMargin = Application.InchesToPoints(0.17)

.Zoom = 100

.FitToPagesWide = 1

.FitToPagesTall = 1

.Orientation = xlLandscape ' придаем листу горизантальное положение (АЛЬБОМНЫЙ)

End With

If MsgBox("Печать текущего изображения", vbYesNo, "Вывод на печать") = vbYes Then Sheets("Обложка").PrintOut Copies:=1, Collate:=True

Application.DisplayAlerts = False ' Выключили системные сообщения...

If MsgBox("Удалить лист ОБЛОЖКА", vbYesNo, "Удаление листа...") = vbYes Then Sheets("Обложка").Delete Else Application.CommandBars("Picture").Visible = True

Application.DisplayAlerts = True 'Включили системные сообщения...

End Sub

Игра «Минное поле»

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

Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim intCol As Integer, intRow As Integer

Dim intMinesAround As Integer

Dim fInGameField As Boolean

' Определим, попадает ли в игровое поле выделенная ячейка

fInGameField = (Target.Row >= 2) And (Target.Row <= 7) _

And (Target.Column >= 2) And (Target.Column <= 7)

' Обрабатываем выделение ячейки

If Target.Value = "*" And fInGameField Then

' Пользователь выделил ячейку с миной - покажем мину

Target.Font.Color = RGB(0, 0, 0)

Target.Interior.Color = RGB(255, 0, 0)

' Пользователь проиграл!

EndGame

ElseIf fInGameField Then

' Пользователь выделил пустую ячейку. Оформим эту ячейку

Target.Interior.Color = RGB(0, 0, 255)

Target.Font.Color = RGB(0, 255, 0)

Target.Font.Size = 16

' Подсчитаем количество мин рядом с ячейкой (вокруг ячейки)

For intCol = Target.Column - 1 To Target.Column + 1

For intRow = Target.Row - 1 To Target.Row + 1

If Target.Worksheet.Cells(intRow, intCol).Value = "*" _

Then

' Нашли очередную мину

intMinesAround = intMinesAround + 1

End If

Next

Next

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

Target.Value = intMinesAround

End If

End Sub

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

Sub NewGame()

' Начало новой игры

' Подготовим поле для игры

InitGame

Dim intRow As Integer, intCol As Integer

Dim intMinesCount As Integer ' Количество мин

' Расставляем мины (то есть в случайные ячейки помещаем _

значения "*" и делаем цвет шрифта таким же, как цвет _

фона этих ячеек)

For intMinesCount = 1 To 10

' Строка для мины (от 2 до 7)

intRow = Int((6 * Rnd) + 1) + 1

' Столбец для мины (от 2 до 7)

intCol = Int((6 * Rnd) + 1) + 1

' Ставим мину, если ячейка пустая

If Cells(intRow, intCol) <> "*" Then

Cells(intRow, intCol).Font.Color = _

Cells(intRow, intCol).Interior.Color

Cells(intRow, intCol).Value = "*"

Else

' В данной ячейке мина есть - продолжим поиск ячеек

intMinesCount = intMinesCount - 1

End If

Next

' Вывод информации о количестве мин в строку состояния

Application.StatusBar = "Количество мин " & intMinesCount

End Sub

Sub InitGame()

' Раскраска (оформление) листа перед началом игры

Dim intRow As Integer, intCol As Integer

' Цвет фона всех ячеек

Cells.Interior.Color = RGB(0, 200, 75)

' Цвет шрифта всех ячеек

Cells.Font.Color = RGB(0, 0, 0)

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

Cells.Font.Size = 18

' Все надписи - по центру

Cells.HorizontalAlignment = xlCenter

' Всем ячейкам игрового поля назначим особый цвет

For intRow = 2 To 7

For intCol = 2 To 7

Cells(intRow, intCol).Interior.Color = RGB(200, 200, 200)

Cells(intRow, intCol).Value = ""

Next

Next

End Sub

Sub EndGame()

' Завершение игры (поражение)

Dim intRow As Integer, intCol As Integer

' Покажем все мины. Для этого сделаем цвет шрифта всех ячеек _

черным (ведь во всех ячейках с минами "*" цвет шрифта и цвет _

заливки одинаковы)

For intRow = 2 To 7

For intCol = 2 To 7

If Cells(intRow, intCol).Value = "*" Then

Cells(intRow, intCol).Font.Color = RGB(0, 0, 0)

End If

Next

Next

MsgBox "Проигрыш"

End Sub