Главная страница
Навигация по странице:

  • Листинг 6.2.

  • Листинг 6.3.

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


    Скачать 1.35 Mb.
    НазваниеГотовые макросы в vba excel, Миронов Глава Макросы 9
    Дата06.02.2018
    Размер1.35 Mb.
    Формат файлаdoc
    Имя файла33980_7d1642e70814394f108d07a8a2edd23e.doc
    ТипДокументы
    #35930
    страница41 из 47
    1   ...   37   38   39   40   41   42   43   44   ...   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
    1   ...   37   38   39   40   41   42   43   44   ...   47


    написать администратору сайта