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

Создание подписей к данным диаграммы

Листинг 5.12. Подписи к данным диаграммы

Sub ShowLabels()

Dim rgLabels As Range ' Диапазон с подписями

Dim chrChart As Chart ' Диаграмма

Dim intPoint As Integer ' Точка, для которой добавляется подпись

' Определение диаграммы

Set chrChart = ActiveSheet.ChartObjects(1).Chart

' Запрос на ввод диапазона с исходными данными

On Error Resume Next

Set rgLabels = Application.InputBox _

(prompt:="Укажите диапазон с подписями", Type:=8)

If rgLabels Is Nothing Then Exit Sub

On Error GoTo 0

' Добавление подписей

chrChart.SeriesCollection(1).ApplyDataLabels _

Type:=xlDataLabelsShowValue, _

AutoText:=True, _

LegendKey:=False

' Просмотр диапазона и назначение подписей

For intPoint = 1 To chrChart.SeriesCollection(1).Points.Count

chrChart.SeriesCollection(1). _

Points(intPoint).DataLabel.Text = rgLabels(intPoint)

Next intPoint

End Sub

Sub DeleteLabels()

' Удаление подписей диаграммы

ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1). _

HasDataLabels = False

End Sub

Глава 6. Создание полезных программ

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

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

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

Дата добавления: 2015-06-25