В Visual Basic я могу назвать себя новичком (поставил полную версию только 2 недели назад), хотя имеется опыт написания несложных программ на Quick Basic и Visual Basic for Application. Для того чтобы более полно познакомится с возможностями этого языка решил написать какую-либо несложную программу. Выбор был остановлен на игровой программе, т.к. для игр характерна четкая постановка задачи и довольно показательный результат. Результаты моих изысканий в области Visual Basic изложены в этой статье.
Попробуем сами написать игру Collumns. Для тех кто не знает это тетрисоподобная игра, в которой в стакан падают прямоугольники состоящие из 3 разноцветных квадратных сегментов. При совпадении цветов у трех и более сегментов они уничтожаются. Наверно, это самый простой вариант игр подобного вида, т.к. все управление сводится к смещению фигуры вправо и влево, а также перемене цветов (главное, что нет никаких поворотов). Тем не менее, игра довольно интересная.
Сразу оговорюсь, приведенный код далек от идеала, но я думаю, даже его изучение и повторение будет довольно полезно начинающим программистам, а полученный результат довольно осязаем и Вы сможете похвастаться, что сами написали игру (по крайней мере поняли, как она работает). Продвинутым программистам пример также может быть полезен, на его основе они могут написать свою более качественную и красивую игру в которую мы с большим удовольствием сыграем.
Начнем разработку игры как обычно с создания формы (имя по умолчанию Form1). Здесь вы можете полностью положиться на свои дизайнерские способности. Единственное что необходимо это наличие на форме элемента рисунок размером 3000х6000 твипов с именем Picture1, выполняющего роль игрового поля, и элемента метка с именем MyPoint, на которую мы будем выводить очки. Для тех, кто не желает сам работать над дизайном могу предложить свой вариант см. рис.1.
Рис.1. Вид формы для игры
В обработчик события Picture1_KeyDown необходимо занести следующий код.
Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)
If Bloking = 1 Then Exit Sub
Select Case KeyCode
Case vbKeyUp: ChangeColor
Case vbKeyLeft: MoveLeft
Case vbKeyRight: MoveRight
Case vbKeyDown: notPause = 1
Case vbKeyEscape: pause
End Select
End Sub
Так же необходимо создать кнопку (или метку) для запуска игры, которая должна вызывать процедуру Main и кнопку, вызывающую процедуру Pause. Например так:
Private Sub Метка2_Click()
Main
End Sub
Private Sub Метка3_Click()
pause
End Sub
На этом подготовку формы можно считать законченной.
Приступим к самой программе. На самом деле программа очень простая. Единственный сложный момент в ней это процедура, которая будет искать и удалять одноцветные сегменты.
Первоначально необходимо описать все переменные, которые мы планируем использовать в любом программном модуле. Их в данном случае довольно много:
Option Explicit
Public nxt(3) As Integer ' текущие цвета фигуры
Public clm1 As Integer, rd1 As Integer
' в этих переменных хранятся текущие номера строки и столбца
Public matrnm(13, 7) As String, matr(13, 7) As Integer
' массивы для хранения игрового поля и имен элементов на поле
Public klip As Integer, och As Long
Public notPause As Integer
Public Bloking As Integer
Public nameid As Long
Public nm(3) As String
Public tcsp1 As Label 'три ссылки на объект
Public tcsp2 As Label
Public tcsp3 As Label
Затем переходим к первой процедуре. Эта процедура вызывается при запуске игры. Она должна подготовить игровое поле, очистить все используемые массивы, подготовить датчик случайных чисел, а затем вызывать все другие процедуры для организации игры. Код процедуры следующий:
Sub Main()
Dim fff As Control
Erase matr, matrnm
' очистка используемых массивов
matr(13, 1) = 1: matr(13, 2) = 1: matr(13, 3) = 1 matr(13, 4) = 1: matr(13, 5) = 5: matr(13, 6) = 1:
For Each fff In Form1.Controls
If Left$(fff.Name, 2) = "lb" Then
Form1.Controls.Remove fff.Name
End If
Next: ' подготовка игрового поля
och = 0: Randomize (Timer)
' инициализация генератора случ. чисел
Do ' основной цикл программы
init ' добавление фигуры
If matr(3, clm1) > 0 Then Exit Do
Dropping ' движение фигуры вниз
Do
klip = 0: Bloking = 1
' блокировка клавиатуры на время удаления
udal
Bloking = 0: notPause = 0
Loop Until klip = 0
Loop
MsgBox "ВСЕ!!!"
End Sub
Следующая процедура вызывается при создании каждой новой фигуры. Заметим, что фигура состоит из трех разноцветных меток квадратной формы. Здесь же присваивается значение переменным содержащие ссылки на эти метки. Это позволяет потом обращаться к ним из любого места программы.
Sub init()
' создание на экране новой фигуры
Dim i As Integer
clm1 = Int(Rnd * 6) + 1
nxt(1) = Int(Rnd * 5) + 10
nxt(2) = Int(Rnd * 5) + 10
nxt(3) = Int(Rnd * 5) + 10
' цвета сегментов фигуры
nameid = nameid + 1: nm(3) = "lbl" & CStr(nameid)
Set tcsp3 = Form1.Controls.Add("VB.Label", nm(3), _ Form1.Picture1)
' добавление сегмента
SetObj tcsp3, (clm1 - 1) * 500, 1000, nxt(3)
' установка параметров сегмента
nameid = nameid + 1: nm(2) = "lbl" & CStr(nameid)
Set tcsp2 = Form1.Controls.Add("VB.Label", nm(2), _ Form1.Picture1)
SetObj tcsp2, (clm1 - 1) * 500, 500, nxt(2)
nameid = nameid + 1: nm(1) = "lbl" & CStr(nameid)
Set tcsp1 = Form1.Controls.Add("VB.Label", nm(1), _ Form1.Picture1)
SetObj tcsp1, (clm1 - 1) * 500, 0, nxt(1)
End Sub
Так как при добавлении новой метки необходимо установить ряд ее свойств, причем эти свойства для всех меток одинаковы, то чтобы избежать повторения кода используется процедура SetObj, которой в качестве параметров передается ссылка на объект и значения необходимых свойств.
Sub SetObj(NmObj As Label, objLeft As Integer, _
objTop As Integer, ByVal objColor As Integer)
With NmObj
.BorderStyle = 1
.BackColor = QBColor(objColor)
.Left = objLeft: .Top = objTop
.Height = 500: .Width = 500
.Visible = True
End With
End Sub
Следующая процедура предназначена для организации падения фигуры. Падение выполняется до тех пор, пока не выполнится одно из двух условий - следующая клетка занята или достигнуто дно стакана. В любом случае после этого в соответствующий элемент массива matr заносится цвет оказавшегося там сегмента, а в массив matrnm его имя.
Sub Dropping()
Dim i As Integer, d As Integer
' фигура опускается пока не достигнет дна или другой фигуры
For i = 4 To 13
d = 0
If matr(i, clm1) = 0 Then
d = 1: rd1 = I
Else: matr(i - 3, clm1) = nxt(1):
matrnm(i - 3, clm1) = nm(1)
matr(i - 2, clm1) = nxt(2): matrnm(i - 2, clm1) = nm(2)
matr(i - 1, clm1) = nxt(3): matrnm(i - 1, clm1) = nm(3)
End If
If d = 0 Then Exit For
Call MoveDown
Next i
End Sub
Процедура MoveDown просто медленно двигает нашу фигуру вниз. В принципе здесь можно использовать метод Move.
Sub MoveDown()
Dim i As Integer
For i = 1 To 20 ' за раз опускаемся на 25 твипов
tcsp1.Top = tcsp1.Top + 25
tcsp2.Top = tcsp2.Top + 25
tcsp3.Top = tcsp3.Top + 25
sleep (0.005)
Next i
End Sub
Процедура ChangeColor вызывается в ответ на нажатие клавиши “стрелка вверх” оно циклический меняет цвет сегментов прямоугольника.
Public Sub ChangeColor()
Dim sd As Integer
sd = nxt(1): nxt(1) = nxt(3): nxt(3) = nxt(2): nxt(2) = sd
' просто циклически меняем цвета в массиве
tcsp1.BackColor = QBColor(nxt(1))
tcsp2.BackColor = QBColor(nxt(2))
tcsp3.BackColor = QBColor(nxt(3))
' и устанавливаем соответствующее свойство объектов
End Sub
Две процедуры MoveRight и MoveLeft очень похожи по своей реализации. Они организуют движение фигуры вправо и влево. Движение возможно, если три позиции справа и слева от текущей фигуры пусты, и она не выходит за границы стакана. Само движение реализуется изменением свойства Left.
Public Sub MoveRight()
If matr(rd1, clm1 + 1) + matr(rd1 - 1, clm1 + 1) _
+ matr(rd1 - 2, clm1 + 1) = 0 And clm1 < 6 Then
tcsp1.Left = tcsp1.Left + 500
tcsp2.Left = tcsp2.Left + 500
tcsp3.Left = tcsp3.Left + 500
clm1 = clm1 + 1
End If
End Sub
Public Sub MoveLeft()
If matr(rd1, clm1 - 1) + matr(rd1 - 1, clm1 - 1) _
+ matr(rd1 - 2, clm1 - 1) = 0 And clm1 > 1 Then
tcsp1.Left = tcsp1.Left - 500
tcsp2.Left = tcsp2.Left - 500
tcsp3.Left = tcsp3.Left - 500
clm1 = clm1 - 1
End If
End Sub
Простая процедура Sleep реализует небольшую задержку в программе, в качестве параметра ее передается величина задержки в секундах. Оператор DoEvents внутри позволяет выполнять любые события во время задержки.
Sub sleep(tm)
Dim tm1 As Single
If notPause = 1 Then Exit Sub
‘ если была нажата клавиша Down, то падение без задержки
tm1 = Timer
Do: DoEvents: Loop While tm1 + tm > Timer
End Sub
Остановимся и переведем дух. Уже на этом этапе, если все сделано правильно, наше приложение вполне работоспособно. Добавьте пустую процедуру с именем udal () и запускайте. Если возникли ошибки, то сразу отлаживайте. В общем фигуры уже должны падать и быть управляемыми. Не работает только удаление одноцветных сегментов.
Это самый трудный, но и самый интересный с точки зрения программирования участок программы. Отмечу, что данный код можно было бы значительно упростить, если не реализовывать два эффекта. Первый это плавное падение всех (а не одного) сегментов сразу. Второй постепенное удаление с визуальным уменьшением фигуры. Но если уж взялись программировать игру, то на эффектах не стоит экономить.
Sub udal()
Dim udd(12, 6) As Integer
Dim dsg(12, 6) As Integer
' описываем вспомогательные масивы
Dim i As Integer, j As Integer, kol As Integer
Dim k As Integer, s As Integer, p As Integer
Dim clr As Integer, t As Integer, l As Integer
Dim kl As Integer, clp As Integer, g As Integer
kol = 0
' в этом блоке обрабатываем матрицу с цветами
' и находим все сегменты подлежащие удалению
' затем заносим их в матрицу udd()
For i = 1 To 12
For j = 1 To 6
If matr(i, j) > 0 Then
For k = 1 To 4:
s = 0
Select Case k
Case 1: p = i: clr = matr(i, j)
Do: s = s + 1: p = p + 1
If p > 12 Then Exit Do
Loop While matr(p, j) = clr
Case 2: p = i: t = j: clr = matr(i, j)
Do: s = s + 1: p = p + 1: t = t + 1
If p > 12 Or t > 6 Then Exit Do
Loop While matr(p, t) = clr
Case 3: p = i: t = j: clr = matr(i, j)
Do: s = s + 1: p = p + 1: t = t - 1
If p > 12 Or t < 1 Then Exit Do
Loop While matr(p, t) = clr
Case 4: p = i: t = j: clr = matr(i, j)
Do: s = s + 1: t = t + 1
If t > 6 Then Exit Do
Loop While matr(p, t) = clr
End Select
If s >= 3 Then
kol = s: Beep
Select Case k
Case 1: p = i: For l = 1 To s:udd(p, j) = 1: p = p + 1: Next l
Case 2: p = i: t = j: For l = 1 To s: udd(p, t) = 1:
p = p + 1: t = t + 1: Next l
Case 3: p = i: t = j: For l = 1 To s: udd(p, t) = 1:
p = p + 1: t = t - 1: Next l
Case 4: p = i: t = j: For l = 1 To s: udd(p, t) = 1:
t = t + 1: Next l
End Select
End If
Next k
End If
Next j, i
kl = 0
' плавно уменьшаем элементы, подлежащие удалению
For k = 1 To 5
For i = 1 To 12
For j = 1 To 6
If udd(i, j) Then
Form1.Controls(matrnm(i, j)).Width = _
Form1.Controls(matrnm(i, j)).Width - 50
Form1.Controls(matrnm(i, j)).Height = _
Form1.Controls(matrnm(i, j)).Height - 50
Form1.Controls(matrnm(i, j)).Top = _
Form1.Controls(matrnm(i, j)).Top + 25
Form1.Controls(matrnm(i, j)).Left = _
Form1.Controls(matrnm(i, j)).Left + 25
sleep (0.005)
End If
Next j, i
Next k
'удаляем их
For i = 1 To 12
For j = 1 To 6
If udd(i, j) Then
Form1.Controls.Remove (matrnm(i, j)): matr(i, j) = 0
matrnm(i, j) = ""
kl = kl + 1
End If
Next j, i
If kl = 0 Then Exit Sub
' в зависимости от количества удаленных сегментов
' подсчитываем очки
Select Case kl
Case 3: och = och + 9
Case 4, 5, 6: och = och + kl * 2
Case Is > 6: och = och + kl * 3
End Select
Form1.MyPoint = Right("000000" & CStr(och), 6)
Do
clp = 0
Erase dsg
For i = 1 To 11
For j = 1 To 6
If matr(i, j) > 0 Then
For k = i + 1 To 12
If matr(k, j) = 0 Then dsg(i, j) = dsg(i, g) + 1: clp = 1
Next k
End If
Next j, i
If clp = 0 Then Exit Do
' довольно непонятный блок
' здесь мы сдвигаем вниз те сегменты под которыми
' образовалась пустота
' любознательные могут выполнять это место пошагово
' чтобы разобраться, но главное это работает!
For l = 1 To 5
For i = 1 To 11
For j = 1 To 6
If dsg(i, j) > 0 Then
Form1.Controls(matrnm(i, j)).Top = Form1.Controls(matrnm(i, j)).Top + 100
End If
Next j, i
sleep (0.05)
Next l
For i = 12 To 2 Step -1
For j = 1 To 6
If dsg(i, j) > 0 Or matr(i, j) = 0 Then
matr(i, j) = matr(i - 1, j)
matrnm(i, j) = matrnm(i - 1, j)
End If
Next j, i
For j = 1 To 6
If dsg(1, j) > 0 Or matr(1, j) = 0 Then
matr(1, j) = 0
matrnm(1, j) = ""
End If
Next j
Loop While clp = 1
klip = kl
End Sub
Нам осталось реализовать паузу. Ну а это вообще очень легко.
Sub pause()
MsgBox " Пауза! ", , " Пауза !"
End Sub
Вот и все!
В заключении дать советы по модернизации этой игры, которые вы можете воспринимать в качестве домашнего задания. Советы приведены в порядке возрастания их сложности.
- Добавьте меню, помощь, форму About.
- Используя элемент Image вместо Label сделайте, чтобы падающие сегменты были в виде картинок.