vb_俄罗斯方块

流程图

程序开始 是 1. 2. 3. 4. 5. 设定地图资料 设定界面大小和位置 初始化游戏的运行数据 设定各种方块数据 启动timer 置换下一块为现在方块，检查可否放入地图 否 是否再玩 否 产生下一块 程序结束 Timer依设定时间下移方块 由键盘方向键控制方块移动和变是否移动方块 否 检查方块移动位置是否有障碍 是 检查方块是否无法下移 是 重绘地图方块 删除满行

画面规划

画面规划如图1所示

图1

说明如下： 1：○游戏窗口（Form）。为了避免因改变窗口大小而造成画面呈现不美观，将BorderStyle属性设定为3，即无法以窗口边缘进行窗口大小调整。 2：积分框（Frame） ○

3：累计数框（Frame） ○

4：分数（Label） ○

5：等级（Label） ○

6：构成下一个动作方块所需组件（Image）○。程序设计阶段将Visible设为False，程序执行阶段再依需要改变属性值。 7：○构成地图方块所需组件（Image）。程序设计阶段将Visible设为False，程序执行阶段再依需要改变属性值。 8：构成现在动作方块所需组件（Image）○。程序设计阶段将Visible设为False，程序执行阶段再依需要改变属性值。 9：定时器（Timer）○。

10：方块图形存储组件（ImageList）○。

1. 游戏使用说明

上方向键旋转方块，左右和下方向键移动方块，空格键能让方块骤降，pause按键能暂停游戏。每消除一行得100分，初始等级为1级，满3000分升1级，同时方块下降的速度也变快。

程序代码：

Private Type blocktype

intblockarray(3, 4, 4) As Integer '方块数组 blockpicture As Integer '方块图形 End Type

'所有方块形状数据

Dim blockarray() As blocktype '方块类型数组

'现在方块

Dim nowblocktype As Integer '方块类型 Dim nowblockmode As Integer '方块方向 Dim nowblockpicture As Integer '方块图案 Dim nowblockx As Integer 'x坐标 Dim nowblocky As Integer 'y坐标 Dim nowblockw As Integer '方块宽 Dim nowblockh As Integer '方块高

'下一个方块

Dim nextblocktype As Integer '方块类型 Dim nextblockpicture As Integer '方块图形

'地图数据

Dim mapxs As Integer '地图横向格数 Dim mapys As Integer '地图纵向格数 Dim maparray() As Integer '地图数组

Dim mappicturearray() As Integer '地图中所代表的图案 Dim mapx As Integer '地图x坐标 Dim mapy As Integer '地图y坐标

Dim delcount As Integer '删除行数计数器

'游戏进行数据

Dim score As Double '游戏分数 Dim level As Integer '游戏级数 Dim speed As Integer '游戏速度

Private Declare Sub Sleep Lib \"kernel32\" (ByVal dwMilliseconds As Long)

'窗体加载

Private Sub form_load()

Randomize

Call setmap '设定地图数据

Call setformsize '设定窗体大小 Call setgamedata '初始化游戏数据 Call setblock '设定各种方块数据 Call createnextblock '产生下一方块 Call createnowblock '产生现在方块 Timer1.Enabled = True Timer1.Interval = speed

End Sub

'设定地图数据

Private Sub setmap() mapx = 0 mapy = 735 mapxs = 14 mapys = 18

nowblockw = 375 nowblockh = 375

ReDim maparray(mapxs - 1, mapys - 1)

ReDim mappicturearray(mapxs - 1, mapys - 1)

'将地图数据清空,并加载图形组件 For X = 0 To mapxs - 1 For Y = 0 To mapys - 1

Load imgmapblock(imgmapblock.Count) imgmapblock(imgmapblock.Count - 1). _ Move (X * nowblockw + mapx), _ (Y * nowblockh + mapy), _ nowblockw, _ nowblockh

imgmapblock(imgmapblock.Count - 1).Visible = False maparray(X, Y) = 0

mappicturearray(X, Y) = 0 Next Y Next X End Sub

'设定窗体大小位置

Private Sub setformsize() Dim frmleft As Integer Dim frmtop As Integer Dim frmw As Integer Dim frmh As Integer

frmleft = (Screen.Width - Me.Width) / 2 frmtop = (Screen.Height - Me.Height) / 2

frmw = nowblockw * mapxs + (Me.Width - Me.ScaleWidth) frmh = nowblockh * mapys + (Me.Height - Me.ScaleHeight) Me.Move frmleft, frmtop, frmw, frmh + 735 imgnowblock(0).Width = nowblockw imgnowblock(0).Height = nowblockh imgmapblock(0).Width = nowblockw imgmapblock(0).Height = nowblockh

End Sub

'初始化游戏进行数据

Private Sub setgamedata() score = 0 level = 1 speed = 800

lbscore(0).Caption = score lblevel(0).Caption = level End Sub

'设定方块数据

Private Sub setblock() ReDim blockarray(6) Dim intcount As Integer

blockarray(0).intblockarray(0, 2, 1) = 1 ' blockarray(0).intblockarray(0, 1, 2) = 1 blockarray(0).intblockarray(0, 2, 2) = 1 blockarray(0).intblockarray(0, 3, 2) = 1

blockarray(1).intblockarray(0, 1, 1) = 1 ' L blockarray(1).intblockarray(0, 1, 2) = 1 blockarray(1).intblockarray(0, 2, 2) = 1 blockarray(1).intblockarray(0, 3, 2) = 1

blockarray(2).intblockarray(0, 3, 1) = 1 ' blockarray(2).intblockarray(0, 1, 2) = 1 blockarray(2).intblockarray(0, 2, 2) = 1 blockarray(2).intblockarray(0, 3, 2) = 1

blockarray(3).intblockarray(0, 1, 2) = 1 ' blockarray(3).intblockarray(0, 2, 2) = 1 blockarray(3).intblockarray(0, 3, 2) = 1 blockarray(3).intblockarray(0, 4, 2) = 1

blockarray(4).intblockarray(0, 1, 1) = 1 'Z blockarray(4).intblockarray(0, 2, 1) = 1 blockarray(4).intblockarray(0, 2, 2) = 1 blockarray(4).intblockarray(0, 3, 2) = 1

blockarray(5).intblockarray(0, 2, 1) = 1 ' blockarray(5).intblockarray(0, 3, 1) = 1 blockarray(5).intblockarray(0, 1, 2) = 1

倒T形 形 倒L形 一字形 字形 倒Z字形 blockarray(5).intblockarray(0, 2, 2) = 1

For i = 0 To 3

blockarray(6).intblockarray(i, 2, 2) = 1 '田字形 blockarray(6).intblockarray(i, 2, 3) = 1 blockarray(6).intblockarray(i, 3, 2) = 1 blockarray(6).intblockarray(i, 3, 3) = 1 Next i

For i = 0 To 5 '依序为倒T形，L形，倒L形，一字形，Z形和倒Z形 For j = 1 To 3 '每一形状要做三次旋转，每次顺时针90 intcount = 0

If i > 2 And (j Mod 2 = 0) Then For X = 0 To 4 For Y = 0 To 4 blockarray(i). _

intblockarray(j, X, Y) = blockarray(i). _ intblockarray((j - 1), 4 - Y, X)

If blockarray(i).intblockarray(j, X, Y) = 1 Then intcount = intcount + 1 End If

If intcount >= 4 Then Exit For Next Y

If intcount = 4 Then Exit For Next X Else

For X = 0 To 4 For Y = 0 To 4

blockarray(i).intblockarray(j, X, Y) = _

blockarray(i).intblockarray((j - 1), Y, 4 - X) If blockarray(i).intblockarray(j, X, Y) = 1 Then intcount = intcout + 1 End If

If intcount >= 4 Then Exit For Next Y

If intcount >= 4 Then Exit For Next X End If Next j Next i End Sub

'产生下一个方块图形

Private Sub createnextblock() Dim intcount As Integer

nextblocktype = Rnd() * UBound(blockarray) '随机数产生方块形态 '随机数产生方块图案

nextblockpicture = Rnd() * (iglblockpicture.ListImages.Count - 1) + 1

'第一次初始将组件动态新增至4个 If imgnextblock.Count < 4 Then

Do

Load imgnextblock(imgnextblock.Count) Loop While imgnextblock.Count < 4 End If

'将下一个方块画在窗体上方 intcount = 0 For X = 0 To 4 For Y = 1 To 2

If blockarray(nextblocktype).intblockarray(0, X, Y) = 1 Then Set imgnextblock(intcount).Picture =

iglblockpicture.ListImages(nextblockpicture).Picture

imgnextblock(intcount).Move (2000 + X * 195), (30 + Y * 195), 195, 195

imgnextblock(intcount).Visible = True intcount = intcount + 1 End If

If intcount >= 4 Then Exit For Next Y

If intcount >= 4 Then Exit For Next X

End Sub

'产生现在方块形状

Private Sub createnowblock() Dim intcount As Integer Dim strgameover As String nowblocktype = nextblocktype

nowblockpicture = nextblockpicture nowblockx = (mapxs - 5) / 2 - 1 nowblocky = -1

nowblockmode = 0

'第一次初始将组件动态新增至4个 If imgnowblock.Count < 4 Then Do

Load imgnowblock(imgnowblock.Count) Loop While imgnowblock.Count < 4 End If

'检查新产生的方块是否可以放在地图中

If checkput(nowblockx, nowblocky, nowblockmode) = False Then strgameover = MsgBox(\"你输了，继续玩吗？\vbQuestion + vbYesNo, \"游戏结束\")

If strgameover = vbNo Then End Else

Do While imgmapblock.Count > 1

Unload imgmapblock(imgmapblock.Count - 1) Loop

Call form_load End If Else

Call drawblock '画出方块 Call createnextblock End If End Sub

'键盘事件

Private Sub form_keydown(keycode As Integer, shift As Integer)

If Timer1.Enabled = True Or keycode = vbKeyPause Then Select Case keycode Case vbKeyUp

nowblockmode = nowblockmode + 1

If nowblockmode > 3 Then nowblockmode = 0 If checkput(nowblockx, nowblocky, nowblockmode) = False Then nowblockmode = nowblockmode - 1

If nowblockmode < 0 Then nowblockmode = 3 Else

Call drawblock '画出方块 End If

Case vbKeyDown

If checkput(nowblockx, nowblocky + 1, nowblockmode) = True Then

nowblocky = nowblocky + 1 Call drawblock Else

Call checkbottom End If

Case vbKeyLeft

If checkput(nowblockx - 1, nowblocky, nowblockmode) = True Then

nowblockx = nowblockx - 1 Call drawblock End If

Case vbKeyRight

If checkput(nowblockx + 1, nowblocky, nowblockmode) = True Then

nowblockx = nowblockx + 1 Call drawblock End If

Case vbKeySpace

Do While checkput(nowblockx, nowblocky + 1, nowblockmode) = True

nowblocky = nowblocky + 1 Loop

Call drawblock Call checkbottom

Case vbKeyPause

Timer1.Enabled = Not Timer1.Enabled

Case vbKeyEscape Unload Me

End Select End If

End Sub

'画出方块

Private Sub drawblock()

Dim intcount As Integer intcount = 0

For X = nowblockx To (nowblockx + 4) For Y = nowblocky To (nowblocky + 4)

If blockarray(nowblocktype).intblockarray(nowblockmode, (X - nowblockx), (Y - nowblocky)) = 1 Then

Set imgnowblock(intcount).Picture =

iglblockpicture.ListImages(nowblockpicture).Picture imgnowblock(intcount).Move (X * nowblockw + mapx), (Y * nowblockh + mapy), nowblockw, nowblockh

imgnowblock(intcount).Visible = True intcount = intcount + 1 End If

If intcount >= 4 Then Exit For Next Y

If intcount >= 4 Then Exit For Next X End Sub

'检查方块是否可以放置

Private Function checkput(cx As Integer, cy As Integer, cm As Integer) As Boolean

checkput = True

For X = cx To (cx + 4)

For Y = cy To (cy + 4) If blockarray(nowblocktype).intblockarray(cm, (X - cx), (Y - cy)) = 1 Then

If X < 0 Or X > (mapxs - 1) Or _ Y < 0 Or Y > (mapys - 1) Then checkput = False Else

If maparray(X, Y) = 1 Then checkput = False End If End If End If

If intcount >= 4 Then Exit For Next Y

If checkput = False Then Exit For Next X End Function

'定时器

Private Sub Timer1_Timer()

If checkput(nowblockx, nowblocky + 1, nowblockmode) = True Then nowblocky = nowblocky + 1 Call drawblock Else

Call checkbottom End If End Sub

'方块到底检查

Private Sub checkbottom()

Timer1.Enabled = False

Call Wirtemap '将到底的方块数据写入地图数组中 Call deletefull '删除满行

If delcount > 0 Then Call reloadmap '假如有刪除行则重新加载地图 Call checkgamedata '检查游戏数据 Call createnowblock '产生新方块 Timer1.Enabled = True End Sub

'将到底的方块数据写入地图数组中 Private Sub Wirtemap()

Dim intcount As Integer '方块计数器 intcount = 0 For X = 0 To 4 For Y = 0 To 4 If blockarray(nowblocktype).intblockarray(nowblockmode, X, Y) = 1 Then

'读取到方块数组中的值为1时，方块计数器加1 intcount = intcount + 1

maparray(nowblockx + X, Y + nowblocky) = 1

mappicturearray(X + nowblockx, Y + nowblocky) = nowblockpicture

Set imgmapblock((nowblockx + X) + (nowblocky + Y) * mapxs).Picture = _

iglblockpicture.ListImages(mappicturearray((nowblockx + X), (nowblocky + Y))).Picture

imgmapblock((nowblockx + X) + (nowblocky + Y) * mapxs).Move ((nowblockx + X) * nowblockw + mapx), _

((nowblocky + Y) * nowblockh + mapy), nowblockw, nowblockh

imgmapblock((nowblockx + X) + (nowblocky + Y) * mapxs).Visible = True

End If

'当方块计数器为4时表示已经将数组中有方块之值写入地图 If intcount >= 4 Then Exit For Next Y

If intcount >= 4 Then Exit For Next X End Sub '删除满行

Private Sub deletefull()

Dim blfull As Boolean '满行旗标 delcount = 0 '删除行数计数器归0

Dim reline(4) As Boolean '记录满行行数

For Y = nowblocky To nowblocky + 4

blfull = True '先将满行旗标设为TRUE If Y < mapys And Y >= 0 Then

For X = 0 To mapxs - 1

If maparray(X, Y) = 0 Then blfull = False End If Next X Else

blfull = False End If

reline(Y - nowblocky) = blfull

If blfull = True Then delcount = delcount + 1 Next Y

'当有满行发生时

If delcount > 0 Then For i = 1 To 4

For yy = nowblocky To nowblocky + 4 If reline(yy - nowblocky) = True Then For mxx = 0 To mapxs - 1

imgmapblock(mxx + yy * mapxs).Visible = _ Not imgmapblock(mxx + yy * mapxs).Visible DoEvents Next mxx End If Next yy

If i Mod 2 = 0 Then

Sleep (50 / delcount) Else

Sleep (10 / delcount)

End If Next i

'移动地图数组数据

For yyy = nowblocky To nowblocky + 4

If reline(yyy - nowblocky) = True Then For my = yyy To 1 Step -1 For mx = 0 To mapxs - 1

maparray(mx, my) = maparray(mx, my - 1)

mappicturearray(mx, my) = mappicturearray(mx, my - 1) Next mx Next my

'将地图数组第0行设为0

For mx = 0 To mapxs - 1 maparray(mx, 0) = 0 Next mx End If Next yyy End If End Sub

'重新加载地图

Private Sub reloadmap()

For X = 0 To mapxs - 1

For Y = 0 To mapys - 1

If maparray(X, Y) = 1 Then

Set imgmapblock(X + Y * mapxs).Picture = _ iglblockpicture.ListImages(mappicturearray(X, Y)).Picture

imgmapblock(X + Y * mapxs).Move (X * nowblockw + mapx), (Y * nowblockh + mapy), nowblockw, nowblockh

imgmapblock(X + Y * mapxs).Visible = True Else

imgmapblock(X + Y * mapxs).Visible = False End If Next Y Next X End Sub

'检查游戏数据

Private Sub checkgamedata()

score = score + delcount * delcount * 100 '分数计算 level = 1 + score \\ 3000 '等级计算 speed = speed - 1

If speed <= 0 Then speed = 1 lbscore(0).Caption = score lblevel(0).Caption = level End Sub

'窗体移除

Private Sub form_unload(cancel As Integer) '移除地图显示组件

Do While imgmapblock.Count > 1

Unload imgmapblock(imgmapblock.Count - 1) Loop

'移除现在动作方块显示组件

Do While imgnowblock.Count > 1

Unload imgnowblock(imgnowblock.Count - 1) Loop

'移除下一个动作方块显示组件 Do While imgnextblock.Count > 1

Unload imgnextblock(imgnextblock.Count - 1) Loop End Sub