Option Explicit
Private nxt(3) As Integer ' текущие цвета фигуры
Private clm1 As Integer, rd1 As Integer
' в этих переменных хранятся текущие номера строки и столбца
Private matrnm(13, 7) As String, matr(13, 7) As Integer
' массивы для хранения игрового поля и имен элементов на поле
 
Private klip As Integer, och As Long
 
Private notPause As Integer
 
Private Bloking As Integer
 
Private nameid As Long
 
Private nm(3) As String
 
Private tcsp1 As Label 'три ссылки на объект
 
Private tcsp2 As Label
 
Private tcsp3 As Label
 
 
 
 
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub
 
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
 
'На этом подготовку формы можно считать законченной.
 
'Приступим к самой программе. На самом деле программа очень простая. Единственный сложный момент в ней это процедура, которая будет искать и удалять одноцветные сегменты.
 
'Первоначально необходимо описать все переменные, которые мы планируем использовать в любом программном модуле. Их в данном случае довольно много:
 
 
 
'Затем переходим к первой процедуре. Эта процедура вызывается при запуске игры. Она должна подготовить игровое поле, очистить все используемые массивы, подготовить датчик случайных чисел, а затем вызывать все другие процедуры для организации игры. Код процедуры следующий:
 
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
 On Error Resume Next
For i = 1 To 20 ' за раз опускаемся на 25 твипов
 
tcsp1.Top = tcsp1.Top + 25
 
tcsp2.Top = tcsp2.Top + 25
 
tcsp3.Top = tcsp3.Top + 25
 
sleep (0.01)
 
Next i
 
End Sub
 
'Процедура ChangeColor вызывается в ответ на нажатие клавиши “стрелка вверх” оно циклический меняет цвет сегментов прямоугольника.
 
Private 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.
 
Private 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
 
Private 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