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 '倒T形 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 '倒L形 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 '倒Z字形 blockarray(5).intblockarray(0, 3, 1) = 1
blockarray(5).intblockarray(0, 1, 2) = 1
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。