Вы устали от навязчивой рекламы, лутбоксов и монетизации в мобильных играх?

Тогда я расскажу вам, как создать игру "3 в 1" на рабочем листе Excel. Бесплатно, без регистрации и СМС.

Предыдущая статья, в которой я рассказал, как сделать простейшие пятнашки с использованием VBA.

Технически получилось у меня не совсем "3 в 1", и дворецкий не станет вымогать у вас звёздочки, чтобы поменять сломанный комод. Игра больше похожа на Toon Blast (есть на обеих мобильных платформах).

Вы устали от навязчивой рекламы, лутбоксов и монетизации в мобильных играх?

Поле наполнено квадратиками разного цвета. Если рядом стоят 2 или больше квадратов, то их можно удалить. Верхние квадраты падают на освободившиеся места. Когда образовываются пустые колонки, то блоки смещаются влево. Чем больше массив блоков, который вы уберете за один раз, тем больше очков заработаете.

Сперва организуем органы управления. Выставляем на странице три переключателя, которые будут отвечать за уровни сложности, и слайдер, который меняет размер игрового поля.

Путем нехитрых проб и ошибок я придумал такое разделение.

1. Лёгкий уровень: 3 вида блоков, средний - 4, сложный - 5.

2. Малое поле: 10х10 клеток, среднее - 14х14 клеток, большое - 18х18.

Переключатели и слайдер необходимо соединить с какими-либо ячейками рабочего стола. В моем случае это "А2" и "А6" соответственно.

Далее в режиме редактирования кода создаем модуль "createModule", инициализируем публичные переменные:

Public rngPlayField As Range, intSize As Byte, intNumSigns As Byte, _ arrSigns() As Variant, arrField() As Variant

Первая отвечает за игровое поле на листе, вторая - за размер поля, третья - за количество типов блоков, четвертая содержит в себе данные для декорирования блоков, пятая - это массив, который дублирует игровое поле (необходим для быстродействия программы).

Я понимаю, что публичные переменные - зло, но в этот раз мы идем простым путем.

Создаем метод:

Sub initializeField() Dim levelNum As Range, sizeNum As Range, i As Byte Set levelNum = Sheets("FIELD").Range("A2") Set sizeNum = Sheets("FIELD").Range("A6") 'определяем уровень сложности (количество типов символов) For i = 1 To 3 If levelNum.Value = i Then intNumSigns = i + 2 End If Next 'определяем размер поля Select Case sizeNum.Value Case 0 intSize = 10 Case 1 intSize = 14 Case 2 intSize = 18 End Select 'заносим в переменную данные о поле Set rngPlayField = _ Sheets("FIELD").Range("D2").Resize(intSize, intSize) 'очищаем предыдущее поле With Sheets("FIELD").Range("D2").Resize(18, 18) .ClearContents .ClearFormats End With Call createField End Sub

Эта программа определяет размер игрового поля и уровень сложности, а потом вызывает метод, который создает это самое поле.

Я решил, что игровые блоки будут декорированы разными символами. Для этого я использовал функцию ChrW(), которая позволяет показать символ Unicode по его индексу. Через цикл я вывел все символы на рабочую страницу Excel и приступил к поиску.

Когда я нашел самые удачные символы, то поместил их на отдельный лист. Ячейки покрасил в цвета, которые подошли больше всего, и написал в новом модуле (stuffModule) небольшую функцию. Она находит цвет ячейки и возвращает его индекс. Эту функцию я использовал на рабочем листе.

Код функции:

Function getIndex(icell As Range) As String getIndex = icell.Interior.Color End Function

ОТСТУПЛЕНИЕ
Excel выполняет все действия в массиве быстрее, чем аналогичные действия на рабочем листе. Поэтому использовать массивы в такой игре жизненно необходимо.
Советую использовать параметр Option Base 1, который приводит нижнюю границу массивов к единице. Это немного расходится с общепринятой практикой, но в Excel часто приходится совмещать массивы и диапазоны. Ссылки на диапазоны начинаются с единицы.

Следующая процедура использует массив для формирования игрового поля:

Sub createField() Dim intRndSign As Byte, countFD As Integer, countSD As Integer ReDim arrField(intSize, intSize) arrSigns() = Sheets("DATA").Range("A1:B5").Value 'наполнение массива случайными символами For countFD = 1 To intSize For countSD = 1 To intSize intRndSign = _ Application.WorksheetFunction.RandBetween(1, intNumSigns) arrField(countFD, countSD) = arrSigns(intRndSign, 1) Next Next 'вывод данных массива на экран rngPlayField.Cells = arrField() Call decorateField End Sub

Этот метод инициализирует отдельный массив, который содержит данные символов и их цвет (получены со второго листа).

Далее в зависимости от уровня сложности он наполняет массив игрового поля случайными символами из первого массива и выводит диапазон на экран.

И, наконец, пишем процедуру, которая декорирует игровое поле, используя индекс цвета определенного символа:

Sub decorateField() Dim fndColor As Range, countSigns As Byte, fndBlank As Range 'настройка границ и шрифта With rngPlayField With .Font .size = 22 .Color = vbWhite .Bold = True End With .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter With .Borders .LineStyle = xlContinuous .Weight = xlMedium .Item(xlInsideHorizontal).Color = vbWhite .Item(xlInsideVertical).Color = vbWhite End With End With 'настройка цвета For Each fndColor In rngPlayField.Cells For countSigns = 1 To intNumSigns If fndColor.Value = arrSigns(countSigns, 1) Then fndColor.Interior.Color = arrSigns(countSigns, 2) End If Next Next For Each fndBlank In rngPlayField.Cells If fndBlank.Value = "" Then fndBlank.Interior.Color = vbWhite End If Next End Sub

Примеры того, что получается:

Сперва необходимо, как и в случае с пятнашками, создать процедуру, которая реагирует на выбор какой-либо ячейки.

Для этого в модуле листа, на котором находится игровое поле, пишем следующее (об отдельных, еще не описанных процедурах я расскажу позже):

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Cells.count > 1 Then Exit Sub ElseIf Not Application.Intersect(rngPlayField, Target) _ Is Nothing And Target.Value <> "" Then cellValue = Target.Value Call clearCells(Target) Call countScore Call checkEmpty Call checkColumns Call checkLoose End If End Sub

Создаем модуль "playModule", инициализируем публичную переменную cellValue (int) (для прошлого блока). Создаем новый метод и описываем в нем процедуру нажатия на ячейку:

Sub clearCells(ByVal rngCell As Range) Dim checkCells As Integer, countSigns As Variant For checkCells = -1 To 1 Step 2 'проверка ячеек сверху и снизу If rngCell.Offset(checkCells, 0).Value = cellValue Then With rngCell.Offset(checkCells, 0) .Interior.Color = vbWhite .Value = "" End With Call clearCells(rngCell.Offset(checkCells, 0)) End If 'проверка ячеек слева и справа If rngCell.Offset(0, checkCells).Value = cellValue Then With rngCell.Offset(0, checkCells) .Interior.Color = vbWhite .Value = "" End With Call clearCells(rngCell.Offset(0, checkCells)) End If Next 'Сохранение данных в массив arrField() = rngPlayField End Sub

В данном случае используем рекурсию. Если программа выявила, что не все одинаковые ячейки убраны, она вызывает сама себя.

Далее пишем код, который проверяет поле на наличие пустых ячеек. Если над такой ячейкой есть заполненный блок, то он "падает" вниз.

Sub checkEmpty() Dim countFD As Integer, countSD As Integer, countBlank As Integer 'FD - firstDimention, sd - secondDimention For countFD = 2 To intSize For countSD = 1 To intSize 'Если элемент массива пуст и если верхний элемент содержит значение, то они меняются местами If arrField(countFD, countSD) = "" And arrField(countFD - 1, countSD) <> "" Then arrField(countFD, countSD) = arrField(countFD - 1, countSD) arrField(countFD - 1, countSD) = "" countBlank = countBlank + 1 End If Next Next If countBlank > 0 Then Call checkEmpty Else rngPlayField.Cells = arrField() Call decorateField End If End Sub

Тут все просто. Запускается счетчик, который проверяет количество упавших блоков. Если счетчик больше нуля, то подпрограмма запускает сама себя и снова проверяет поле на наличие висящих элементов, пока не окажется, что все кубики уже "упали".

Следующий шаг - смещение блоков влево при наличии пустых колонок:

Sub checkColumns() 'сдвиг колонок влево Dim checkColumn As Byte, countElem As Integer, checkNext As Byte For checkColumn = 1 To intSize 'проверяем, есть ли пустые колонки If Application.WorksheetFunction. _ CountA(rngPlayField.Columns(checkColumn)) = 0 _ And Application.WorksheetFunction. _ CountA(rngPlayField.Columns(checkColumn).Offset(0, 1)) <> 0 Then 'если пустые колонки найдены, то они сдвигаются в массиве For countElem = 1 To intSize arrField(countElem, checkColumn) = _ arrField(countElem, checkColumn + 1) arrField(countElem, checkColumn + 1) = "" checkNext = checkNext + 1 Next End If Next rngPlayField.Cells = arrField() Call decorateField 'запускаем рекурсию для повторной проверки If checkNext > 0 Then Call checkColumns End If End Sub

Метод checkColumns() сперва проверяет, есть ли на игровом поле пустые столбцы. Если он их находит, то уже в массиве игрового поля смещает колонки влево, а потом переносит полученный диапазон на рабочий лист.

Сперва надо определиться с методом подсчета очков. Я придумал следующее:

Количество очков = (Количество убранных блоков ^ 2) / 2

Создаем две публичные переменные: sumBlank(int) и globScore(long)

В процедуре clearCells() прописываем следующее условие, которое выполняется при удалении одного блока:

sumBlank = sumBlank+1

Создаем метод подсчета очков countScore():

Sub сountScore() Dim currScore As Long currScore = sumBlank * sumBlank / 2 globScore = globScore + currScore Sheets("FIELD").nowScore.Caption = currScore Sheets("FIELD").globalScore.Caption = globScore sumBlank = 0 End Sub

На листе выставляются два лейбла, в которые каждый ход записываются текущий и глобальный счет.

Важный момент! Не забывайте в процедуре создания игрового поля initializeField() обнулять переменные и значения лейблов:

Sheets("FIELD").nowScore.Caption = 0 Sheets("FIELD").globalScore.Caption = 0 globScore = 0 sumBlank = 0

Наконец, пишем программу, которая проверяет условия поражения (если отсутствуют ячейки, к которым по горизонтали и вертикали примыкают ячейки с таким же символом) и выводит на экран сообщение с количеством заработанных очков:

Sub checkLoose() 'проверка окончания игры Dim rngFndCells As Range, checkOffset As Integer, countSame As Integer For Each rngFndCells In rngPlayField.Cells For checkOffset = -1 To 1 Step 2 If rngFndCells.Offset(0, checkOffset).Value = _ rngFndCells.Value And rngFndCells <> "" Then countSame = countSame + 1 End If If rngFndCells.Offset(checkOffset, 0).Value = _ rngFndCells.Value And rngFndCells <> "" Then countSame = countSame + 1 End If Next Next If countSame = 0 Then MsgBox "Игра окончена! Очки: " & globScore End If End Sub