Информатика. Книга 7 Быстрое размножение рабочей книги 7 Сохранение рабочей книги с именем, представляющим собой текущую дату 7
 Скачать 1.27 Mb.
|
Игра «Минное поле»Листинг 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 Игра «Угадай животное»Листинг 6.4. Игра «Угадай животное» Sub StartGame() Dim intLastRow As Integer ' Номер строки для вставки записей Dim intRow As Integer ' Номер текущей строки Dim intYesRow As Integer ' Номер строки, из которой брать _ данные при утвердительном ответе Dim intNoRow As Integer ' Номер строки, из которой брать _ данные при отрицательном ответе Dim strText As String ' Строка с вопросом или названием _ животного Dim strNewName As String ' Строка с названием нового животного Dim strNewQuestion As String ' Строка с новым вопросом Dim intRes As Integer ' Начало игры MsgBox "Начнем игру. Задумайте животное.", vbOKOnly, _ "Задумайте животное" ' Определение номера ряда для вставки записей. _ intLastRow-1 - номер последнего ряда, содержащего данные intLastRow = Worksheets("Data").Range("D1").Value + 1 ' Данные в таблице идут с первого ряда intRow = 1 Do While intRow < intLastRow ' Текст вопроса или название животного из столбца "A" strText = Worksheets("Data").Cells(intRow, 1).Value ' Номер ряда, из которого брать данные при утвердительном _ ответе, берем из столбца "B" intYesRow = Worksheets("Data").Cells(intRow, 2).Value ' Номер ряда, из которого брать данные при отрицательном _ ответе, берем из столбца "C" intNoRow = Worksheets("Data").Cells(intRow, 3).Value If intYesRow > 0 Then ' В строке strText содержится вопрос. Зададим его intRes = MsgBox(strText, vbYesNo, "Вопрос") If intRes = vbYes Then ' Переходим по утвердительному ответу intRow = intYesRow Else ' Переходим по отрицательному ответу intRow = intNoRow End If Else ' Альтернативы закончились. В строке strText - название _ животного. Спросим, его ли загадали intRes = MsgBox("Это " & strText & "?", vbYesNo, "Вопрос") If intRes = vbYes Then ' Животное угадано MsgBox "Угадано! Спасибо за игру!", vbOKOnly, _ "Игра завершена" Exit Do Else ' Животное не угадали, но данные уже занкончились. _ Нужно пополнить наши данные, чтобы отличать животное _ с названием strText от загаданного ' Ввод названия нового животного strNewName = InputBox("Сдаюсь. Кто это?", _ "Напечатайте название животного") If strNewName <> "" Then ' Ввод вопроса, по которому отличать животных strNewQuestion = InputBox("Задайте вопрос, по " & _ "которому можно отличить '" & strNewName & _ "' от '" & strText & "'", "Напечатайте вопрос") If strNewQuestion <> "" Then ' Определение, какое из животных соответствует _ утвердительному ответу на вопрос intRes = MsgBox("Правильный ответ на ваш " & _ "вопрос - " & strNewName & "'", vbYesNo, _ "Какой ответ на вопрос?") ' Добавление в таблицу названия нового животного Worksheets("Data").Cells(intLastRow, 1). _ Value = strNewName ' Перемещения названия животного, которое было _ ранее, в конец таблицы Worksheets("Data").Cells(intLastRow + 1, 1). _ Value = strText ' Замена названия этого животного вопросом Worksheets("Data").Cells(intRow, 1). _ Value = strNewQuestion ' Корректировка номеров строк для перехода _ в зависимости от того, какое животное является _ правильным ответом на введенный пользователем вопрос If intRes = vbYes Then ' Новое животное - правильный ответ Worksheets("Data").Cells(intRow, 2). _ Value = intLastRow Worksheets("Data").Cells(intRow, 3). _ Value = intLastRow + 1 Else ' Бывшее ранее животное - правильный ответ Worksheets("Data").Cells(intRow, 2). _ Value = intLastRow + 1 Worksheets("Data").Cells(intRow, 3). _ Value = intLastRow End If ' Сохраним номер строки для добавления записей Worksheets("Data").Range("D1").Value = _ intLastRow + 2 End If End If ' Игра завершена. Таблица дополнена MsgBox "Спасибо за игру!", vbOKOnly, "Игра завершена" Exit Do End If End If Loop End Sub |