Программа для составления кроссвордов

Листинг 6.1. Программа для составления кроссворда

Const dhcMinCol = 1 ' Номер первого столбца кроссворда

Const dhcMaxCol = 35 ' Номер последнего столбца кроссворда

Const dhcMinRow = 1 ' Номер первой строки кроссворда

Const dhcMaxRow = 35 ' Номер последней строки кроссворда

 

Sub Clear()

' Выделение и очистка всех используемых для кроссворда ячеек

Range(Cells(dhcMinRow, dhcMinCol), _

Cells(dhcMaxRow, dhcMaxCol)).Select

Selection.Clear

' Удаление сетки всего кроссворда

ClearGrid

 

Range("A1").Select

End Sub

 

Sub ClearGrid()

' Удаление сетки кроссворда (в выделенных ячейках)...

' Возврат прежнего цвета ячеек

Selection.Interior.ColorIndex = xlNone

' Задание начертания границ ячеек по умолчанию

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

Selection.Borders(xlEdgeLeft).LineStyle = xlNone

Selection.Borders(xlEdgeTop).LineStyle = xlNone

Selection.Borders(xlEdgeBottom).LineStyle = xlNone

Selection.Borders(xlEdgeRight).LineStyle = xlNone

Selection.Borders(xlInsideVertical).LineStyle = xlNone

Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

End Sub

 

Sub DrowCrosswordGrid()

' Процедура начертания сетки кроссворда

 

' Задание цвета всех ячеек кроссворда

Selection.Interior.ColorIndex = 35

' Линии по диагонали не нужны

Selection.Borders(xlDiagonalDown).LineStyle = xlNone

Selection.Borders(xlDiagonalUp).LineStyle = xlNone

 

' Задание начертания границ всех диапазонов, входящих _

в выделение, а также границ между соседними ячейками _

всех диапазонов

On Error Resume Next

' Левые границы

With Selection.Borders(xlEdgeLeft)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Правые границы

With Selection.Borders(xlEdgeRight)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Верхние границы

With Selection.Borders(xlEdgeTop)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Нижние границы

With Selection.Borders(xlEdgeBottom)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Вертикальные границы между ячейками

With Selection.Borders(xlInsideVertical)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

' Горизонтальные границы между ячейками

With Selection.Borders(xlInsideHorizontal)

.LineStyle = xlContinuous

.Weight = xlThin

.ColorIndex = xlAutomatic

End With

End Sub

Sub DisplayGrid()

' Включение сетки на листе

ActiveWindow.DisplayGridlines = True

End Sub

 

Sub HideGrid()

' Выключение сетки на листе

ActiveWindow.DisplayGridlines = False

End Sub

 

Sub AutoNumber()

' Нумерация клеток, являющихся началом слов

Dim intRow As Integer ' Текущая строка

Dim intCol As Integer ' Текущий ряд

Dim cell As Range   ' Текущая ячейка (с координатами _

                        (intRow, intCol))

Dim fTop As Boolean ' = True, если cell имеет соседей сверху

Dim fBottom As Boolean ' = True, если cell имеет соседей снизу

Dim fLeft As Boolean ' = True, если cell имеет соседей слева

Dim fRight As Boolean ' = True, если cell имеет соседей справа

Dim intDigit As Integer ' Текущий номер слова в кроссворде

 

intDigit = 1        ' Нумерация слов с 1

 

' Проходим по всем клеткам диапазона, используемого _

для кроссворда, сверху вниз слева направо и анализируем _

каждую угловую и крайнюю (левую и верхнюю) ячейки

For intRow = dhcMinRow To dhcMaxRow

For intCol = dhcMinCol To dhcMaxCol

    ' Текущая ячейка

    Set cell = Cells(intRow, intCol)

 

    ' Проверка, входит ли ячейка в кроссворд (по ее цвету)

    If cell.Interior.ColorIndex = 35 Then

       fLeft = False

       fRight = False

       fTop = False

       fBottom = False

       On Error Resume Next

       ' Определение наличия соседей у ячейки...

       ' сверху

       fTop = cell.Offset(-1, 0).Interior.ColorIndex = 35

       ' снизу

       fBottom = cell.Offset(1, 0).Interior.ColorIndex = 35

       ' слева

       fLeft = cell.Offset(0, -1).Interior.ColorIndex = 35

       ' справа

       fRight = cell.Offset(0, 1).Interior.ColorIndex = 35

       On Error GoTo 0

 

       ' Анализ положения ячейки

       If (Not fTop And Not fLeft) Or _

        (Not fBottom And Not fLeft And fRight) Or _

        (Not fLeft And fRight) Or _

        (Not fTop And fBottom) Then

          ' Ячейка подходит для начала слова

          SetDigit intDigit, cell

          intDigit = intDigit + 1

       End If

    End If

Next intCol

Next intRow

End Sub

 

Sub SetDigit(intDigit As Integer, cell As Range)

' Вставка цифры intDigit в ячейку, заданную параметром cell

cell.Value = intDigit

' Изменение настроек шрифта так, чтобы было похоже _

на настоящий кроссворд

' Маленький размер шрифта

cell.Font.Size = 6

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

cell.HorizontalAlignment = xlLeft

cell.VerticalAlignment = xlTop

End Sub

 

Sub ToPrint()

' Удаление цветовой подсветки кроссворда

Cells.Interior.ColorIndex = xlNone

End Sub

 

Sub ToNumber()

' Закрытие первой формы и переход ко второй

UserForm1.Hide

UserForm2.Show

End Sub

Создать обложку 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

Игра «Угадай животное»

Листинг 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