|
|
************* 俄罗斯方块DIY ***************
键盘控制方法：
1.左右光标键控制方块左右移动；
2.上光标键控制方块顺时针旋转90度；
3.下光标键控制方块加速向下移动。
设计过程：
(一) 在VB6.0中新建一个标准EXE工程
(二) 建立一个窗体，窗体属性设置如下：
名称 = frmErs
Caption = "俄罗斯方块1.12"
(三) 在窗体上添加两个图片框，属性设置如下：
(1)名称 = picPlay
AutoRedraw = True
BackColor = &H00FF0000& '蓝色
(2)名称 = picNext
AutoRedraw = True
BackColor = &H00FF0000& '蓝色
(四) 在窗体上再添加一个标签，属性设置如下：
名称 = lblFenShu
(五) 用菜单编辑器制作如下菜单：
(1)一级菜单项：
标题 = "文件(&F)"
名称 = mnuSet
下属二级菜单项：
标题 = "退出"
名称 = mnuExit
(2)一级菜单项：
标题 = "帮助(&H)"
名称 = mnuHelp
下属二级菜单项：
标题 = "操作提示"
名称 = mnuTopic
(六) 在窗体代码窗口输入如下代码：
Option Explicit
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'按键代码传入Main()主程序中
gKeyRef = KeyCode
End Sub
Private Sub Form_Load()
Me.Top=0
Me.KeyPreview = True
picPlay.ScaleMode = 3 'Pixel
picNext.ScaleMode = 3 'Pixel
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub mnuExit_Click()
'退出
Unload Me
End Sub
Private Sub mnuTopic_Click()
Dim Msg As String
Msg = "键盘控制方法：" & vbCrLf
Msg = Msg & "1.左右光标键控制方块左右移动；" & vbCrLf
Msg = Msg & "2.上光标键控制方块顺时针旋转90度；" & vbCrLf
Msg = Msg & "3.下光标键控制方块加速向下移动。" & vbCrLf & vbCrLf
Msg = Msg & "福建南平 梁远海 20000年10月提供" & vbCrLf
Msg = Msg & " E-Mail: dayang@k12.com.cn"
MsgBox Msg, vbOKOnly + vbQuestion, Me.Caption
End Sub
Private Sub picPlay_KeyDown(KeyCode As Integer, Shift As Integer)
'按键代码传入Main()主程序中
gKeyRef = KeyCode
End Sub
(七) 添加一个新模块moudel1，并输入如下代码：
Option Explicit
Public gKeyRef As Integer
' 游戏操作按键码值全局变量
Dim mErsBar(0 To 8) As Long
' 俄罗斯方块形状定义,数组下标分配如下:
' +---+---+---+
' | 0 | 1 | 2 |
' +---+---+---+
' | 7 | 8 | 3 |
' +---+---+---+
' | 6 | 5 | 4 |
' +---+---+---+
' 之所以这样定义，是为了方便方块类型设置和旋转判断
' 数组元素取值为：是空白 = 0，是方块构件 = 1
Dim mErsPD(2, 2) As Long
' 将二维坐标系转化为mErsBar()对应下标，以进行方块移动的判断
' 数组元素取值如下：
' mErsPD mErsPD mErsPD
' (0, 0) = 0 (1, 0) = 1 (2, 0) = 2
' (0, 1) = 7 (1, 1) = 8 (2, 1) = 3
' (0, 2) = 6 (1, 2) = 5 (2, 2) = 4
' 应用样式：If mErsBar(mErsPD(x,y)) = 0 Then ...
Dim mPlayWindow() As Long
' 运动小窗口的屏幕状况数组
' 数组大小在子程序NewSatrt()中根据mPlayKuan,mPlayGao的值重定义
' 即 ReDim mPlayWindow(-1 To mPlayKuan + 2, 1 To mPlayGao + 2) As Long
' 取上面的下标范围是为了方块运动判断设计上的方便，
' 方块实际运动范围在(1,1)-(mPlayKuan,mPlayGao)之间
' 数组元素取值为：是空白 = 0，是方块构件 > 0，初始值 = -9
Dim mPlayKuan As Long, mPlayGao As Long
' 运动小窗口的相对宽度（容纳方块小构件的列数）和相对高度（容纳方块小构件的行数）
Dim mPlayMovX As Long, mPlayMovY As Long
' 运动小窗口内方块移动中所处位置的左上角相对坐标
Dim mPlayX_SIZE As Long, mPlayY_SIZE As Long
' 运动小窗口内方块小构件实际宽度和高度
Dim mPlayBkColor As Long
' 运动小窗口背景色
Dim mNextX_SIZE As Long, mNextY_SIZE As Long
' 预览小窗口内方块小构件实际宽度和高度
Dim mNextBkColor As Long
' 预览小窗口背景色
Private Sub BarDef(ByVal k As Long)
'定义方块形状子程序
Dim j As Long
Dim a1 As Long, a2 As Long
Dim a3 As Long, a4 As Long
For j = 0 To 8: mErsBar(j) = 0: Next j
Select Case k
Case 0 '长条
a1 = 0: a2 = 2: a3 = -1: a4 = -1
Case 1 '小块1*1
a1 = 1: a2 = 1: a3 = -1: a4 = -1
Case 2 '7字
a1 = 0: a2 = 2: a3 = 7: a4 = 7
Case 3 '反7字
a1 = 0: a2 = 3: a3 = -1: a4 = -1
Case 4 '凹字
a1 = 0: a2 = 3: a3 = 7: a4 = 7
Case 5 '凸字
a1 = 0: a2 = 2: a3 = 8: a4 = 8
Case 6 '2字
a1 = 1: a2 = 1: a3 = 6: a4 = 8
Case 7 '反2字
a1 = 1: a2 = 2: a3 = 7: a4 = 8
Case 8 '墙角
a1 = 1: a2 = 3: a3 = -1: a4 = -1
Case 9 '田字
a1 = 0: a2 = 1: a3 = 7: a4 = 8
Case Else '大块3*3（有出现即类型序号超出k值）
a1 = 0: a2 = 8: a3 = -1: a4 = -1
End Select
For j = a1 To a2: mErsBar(j) = 1: Next j
If a3 > -1 And a4 > -1 Then
For j = a3 To a4: mErsBar(j) = 1: Next j
End If
End Sub
Private Sub BarViewPlay(ByVal BarMode As Long)
'在运动小窗口内显示或消隐方块的子程序
Dim i As Long, j As Long
For i = 0 To 2
For j = 0 To 2
If mErsBar(mErsPD(j, i)) = 1 Then
Call SmallBarPlay(mPlayMovX + j, mPlayMovY + i, BarMode)
mPlayWindow(mPlayMovX + j, mPlayMovY + i) = BarMode
End If
Next j
Next i
End Sub
Private Sub BarViewNext(ByVal BarMode As Long)
'在预览小窗口内展现下一轮方块的子程序
Dim i As Long, j As Long
For i = 0 To 2 '清除旧方块
For j = 0 To 2
Call SmallBarNext(j + 2, i + 2, 0)
Next j
Next i
For i = 0 To 2 '显示新方块
For j = 0 To 2
If mErsBar(mErsPD(j, i)) = 1 Then
Call SmallBarNext(j + 2, i + 2, BarMode)
End If
Next j
Next i
End Sub
Sub Delay(ByVal dd As Double)
' 延时子程序
Dim tt As Double
tt = Timer + dd
Do: Loop Until Timer >= tt
End Sub
Private Sub LineTestAndClear(CleanToTal As Long)
'方块停止下落后对各行是否积满进行测试和作相应处理的子程序
Dim x As Long
Dim y As Long
Dim y1 As Long
Dim ValTmp As Long
Dim Count As Long
Dim CleanAdd As Long
Dim tt As Long
Dim UpPD As Long
Dim DownPD As Long
Dim MinBetween As Long
Dim PW() As Long
CleanAdd = 0
y = mPlayGao
'统计每行方块构件数并作相应处理的两个步骤：
Do
'步骤之一：统计本行已容纳的方块构件数
Count = 0
For x = 1 To mPlayKuan
If mPlayWindow(x, y) > 0 Then Count = Count + 1
Next x
'步骤之二：如果本行积满则分三小步处理：
If Count = mPlayKuan Then
'第一步：行积满计数
CleanAdd = CleanAdd + 1
'第二步：上方各行向下搬移
If y > 1 Then
For y1 = y To 2 Step -1
For x = 1 To mPlayKuan
ValTmp = mPlayWindow(x, y1 - 1)
Call SmallBarPlay(x, y1, ValTmp)
mPlayWindow(x, y1) = ValTmp
Next x
Next y1
y = y + 1
End If
'第三步：清除顶行冗余
For x = 1 To mPlayKuan
Call SmallBarPlay(x, 1, 0)
mPlayWindow(x, 1) = 0
Next x
DoEvents
End If
y = y - 1
Loop Until y < 1
If CleanAdd = 0 Then Exit Sub
CleanToTal = CleanToTal + CleanAdd
'检测并处理各处悬空方块的六个步骤：
Do
'步骤之一：数组复制
PW = mPlayWindow
'步骤之二：遍历所有与底行相邻的方块构件并标记为-1
y = mPlayGao
For x = 1 To mPlayKuan
If PW(x, y) > 0 Then
Call LocMe(PW(), x, y, -1)
End If
Next x
'步骤之三：从找到的第一个悬空方块构件出发遍历所有与本构件相邻的构件并标记为-2
tt = 0
For y = mPlayGao - 1 To 1 Step -1
For x = 1 To mPlayKuan
If PW(x, y) > 0 Then
Call LocMe(PW(), x, y, -2)
tt = -1
Exit For
End If
Next x
If tt = -1 Then Exit For
Next y
'步骤之四：没有悬空方块则退出循环
If tt <> -1 Then Exit Do
'步骤之五：计算标记为-2的悬空方块与下方的方块的最小垂直距离MinBetween
MinBetween = mPlayGao
For x = 1 To mPlayKuan
UpPD = 0
For y = mPlayGao - 1 To 1 Step -1
If PW(x, y) = -2 Then UpPD = y: Exit For
Next y
If UpPD <> 0 Then
DownPD = mPlayGao + 1
For y = UpPD + 1 To mPlayGao
If PW(x, y) = -1 Or PW(x, y) > 0 Then DownPD = y: Exit For
Next y
ValTmp = DownPD - UpPD - 1
If ValTmp > 0 And ValTmp < MinBetween Then MinBetween = ValTmp
End If
Next x
'步骤之六：标记为-2的悬空方块下移MinBetween行
For x = 1 To mPlayKuan
For y = mPlayGao - 1 To 1 Step -1
If PW(x, y) = -2 Then
ValTmp = mPlayWindow(x, y)
mPlayWindow(x, y) = 0
Call SmallBarPlay(x, y, 0)
mPlayWindow(x, y + MinBetween) = ValTmp
Call SmallBarPlay(x, y + MinBetween, ValTmp)
End If
Next y
Next x
DoEvents
Loop
'递归调用(重新检查悬空方块下沉后各行积满情况）
Call LineTestAndClear(CleanToTal)
End Sub
Private Sub LocMe(PW() As Long, ByVal x As Long, ByVal y As Long, ByVal NumVal As Long)
'从坐标为(x,y)的方块构件出发遍历相邻方块构件并标记为NumVal的子程序
ReDim DingWei(0 To mPlayGao * mPlayKuan, 1 To 2) As Long
Dim tt As Long
Dim pd As Long
pd = PW(x, y)
If Not (pd > 0) Then Exit Sub
tt = 0
Do
If y > 1 Then y = y - 1: GoSub Loc1: y = y + 1
If x < mPlayKuan Then x = x + 1: GoSub Loc1: x = x - 1
If y < mPlayGao Then y = y + 1: GoSub Loc1: y = y - 1
If x > 1 Then x = x - 1: GoSub Loc1: x = x + 1
If tt = 0 Then PW(x, y) = NumVal: Exit Do
tt = tt - 1
x = DingWei(tt, 1)
y = DingWei(tt, 2)
Loop
Exit Sub
Loc1:
If PW(x, y) > 0 Then
PW(x, y) = NumVal
DingWei(tt, 1) = x
DingWei(tt, 2) = y
tt = tt + 1
End If
Return
End Sub
Private Sub Main()
'主程序
Dim Speed As Double '方块运动速度控制
Dim iKey As Integer '按键代码
Dim FenShu As Long '计算得分
Dim CleanToTal As Long '本轮积满而被清除的行数统计
Dim BarMode As Long '方块显示模式
Dim k1 As Long '本轮将出现的方块类型序号
Dim k2 As Long '下一轮将出现的方块类型序号
Dim DefColor As Long '标签前景色
Dim StrMsg As String '标签信息
Dim Ref As Integer '游戏结束对话框返回值
frmErs.Show
RESTART: '游戏开始
FenShu = 0
CleanToTal = 0
GoSub JiFen
mPlayKuan = 12 '方块运动小窗口的宽度（列数）设置(建议 6>=mPlayKuan>=50)
mPlayGao = 19 '方块运动小窗口的高度（行数）设置(建议 6>=mPlayGao>=50)
Call NewStart
Randomize Timer
'方块类型有10种，序号为0-9，在BarDef()子程序中定义
k2 = Int(Rnd * 10)
Do
k1 = k2
k2 = Int(Rnd * 10)
BarMode = Int(Rnd * 3) + 1
Call BarDef(k2) '定义下一轮方块
Call BarViewNext(BarMode) '预览下一轮方块
Call BarDef(k1) '定义本轮方块
mPlayMovX = (mPlayKuan + 1) \ 2
mPlayMovY = 1
If MovDownTest() = False Then Exit Do
gKeyRef = 0
Do
Call BarViewPlay(BarMode) '显现本轮方块
Speed = Timer + 0.4
Do
DoEvents '以便从frmErs的键盘事件中传回按键代码gKeyRef
iKey = gKeyRef
If iKey <> 0 Then
gKeyRef = 0
Select Case iKey
Case vbKeyLeft '左光标键
Call BarViewPlay(0)
If MovLeftTest() = True Then mPlayMovX = mPlayMovX - 1: Call Delay(0.025) Else iKey = -1: Call Delay(0.175)
Case vbKeyRight '右光标键
Call BarViewPlay(0)
If MovRightTest() = True Then mPlayMovX = mPlayMovX + 1: Call Delay(0.025) Else iKey = -1: Call Delay(0.175)
Case vbKeyDown '下光标键
Call BarViewPlay(0)
If MovDownTest() = True Then mPlayMovY = mPlayMovY + 1: Call Delay(0.125)
Case vbKeyUp '上光标键
Call BarViewPlay(0)
Call MovTurnTest
Case Else
iKey = -2
End Select
If iKey <> -2 Then Exit Do
End If
Loop While Timer < Speed
If iKey <= 0 Then
If iKey = 0 Or iKey = -2 Then Call BarViewPlay(0)
If MovDownTest() = True Then mPlayMovY = mPlayMovY + 1
End If
If MovDownTest() <> True Then
If mPlayMovY > 1 Then mPlayMovY = mPlayMovY - 1
Call BarViewPlay(BarMode)
Beep
CleanToTal = 0
Call LineTestAndClear(CleanToTal)
If CleanToTal > 0 Then
FenShu = FenShu + 100 + (CleanToTal - 1) * 500
GoSub JiFen
End If
Exit Do
End If
Loop
Loop Until FenShu >= 1000000
'游戏结束后的选择
Call BarViewPlay(BarMode)
Beep
DoEvents
If FenShu >= 1000000 Then
StrMsg = "您是否重新开始玩游戏？"
Ref = MsgBox(StrMsg, vbYesNo + vbQuestion, "令人惊叹的得分！")
Else
StrMsg = "您是否继续玩游戏？"
Ref = MsgBox(StrMsg, vbYesNo + vbQuestion, "游戏结束")
End If
If Ref = vbYes Then
GoTo RESTART
End If
End
JiFen: '计分
StrMsg = "得分:" & Str(FenShu)
frmErs.lblFenShu.Caption = StrMsg
Return
End Sub
Private Function MovDownTest() As Boolean
'方块下落测试函数
Dim tt As Boolean
Dim x As Long, y As Long
Dim a1 As Long, a2 As Long, a3 As Long
tt = True
x = mPlayMovX
y = mPlayMovY + 2
Do
a1 = mErsPD(0, y - mPlayMovY)
a2 = mErsPD(1, y - mPlayMovY)
a3 = mErsPD(2, y - mPlayMovY)
'以下的 mPlayWindow(x, y) <> 0 等价于 (mPlayWindow(x, y) = -9 Or mPlayWindow(x,y) > 0)
If mErsBar(a1) = 1 And mPlayWindow(x, y) <> 0 Then tt = False: Exit Do
If mErsBar(a2) = 1 And mPlayWindow(x + 1, y) <> 0 Then tt = False: Exit Do
If mErsBar(a3) = 1 And mPlayWindow(x + 2, y) <> 0 Then tt = False: Exit Do
y = y - 1
Loop While y >= mPlayMovY
If tt = False Then MovDownTest = False Else MovDownTest = True
End Function
Private Function MovLeftTest() As Boolean
'方块左移测试函数
Dim y As Long
Dim a1 As Long, a2 As Long, a3 As Long
y = 0
Do
a1 = mErsPD(0, y)
a2 = mErsPD(1, y)
a3 = mErsPD(2, y)
If mErsBar(a1) = 1 Then
If mPlayWindow(mPlayMovX - 1, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
If mErsBar(a1) = 0 And mErsBar(a2) = 1 Then
If mPlayWindow(mPlayMovX, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
If mErsBar(a1) = 0 And mErsBar(a2) = 0 And mErsBar(a3) = 1 Then
If mPlayWindow(mPlayMovX + 1, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
y = y + 1
Loop While y < 3
If y <> 1000 Then MovLeftTest = True Else MovLeftTest = False
End Function
Private Function MovRightTest() As Boolean
'方块右移测试函数
Dim y As Long
Dim a1 As Long, a2 As Long, a3 As Long
y = 0
Do
a1 = mErsPD(2, y)
a2 = mErsPD(1, y)
a3 = mErsPD(0, y)
If mErsBar(a1) = 1 Then
If mPlayWindow(mPlayMovX + 3, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
If mErsBar(a1) = 0 And mErsBar(a2) = 1 Then
If mPlayWindow(mPlayMovX + 2, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
If mErsBar(a1) = 0 And mErsBar(a2) = 0 And mErsBar(a3) = 1 Then
If mPlayWindow(mPlayMovX + 1, mPlayMovY + y) <> 0 Then y = 1000: Exit Do
End If
y = y + 1
Loop While y < 3
If y <> 1000 Then MovRightTest = True Else MovRightTest = False
End Function
Private Sub MovTurnTest()
' 使方块顺时针旋转90度的测试与处理的子程序
Dim j As Long, x As Long, tt As Long
Dim b0 As Long, b1 As Long
b0 = mErsBar(6): b1 = mErsBar(7)
For j = 7 To 2 Step -1
mErsBar(j) = mErsBar(j - 2)
Next j
mErsBar(1) = b1: mErsBar(0) = b0
x = mPlayMovX: tt = MovDownTest()
If tt = False Then
If x >= 2 Then mPlayMovX = x - 1: tt = MovDownTest()
End If
If tt = False Then
If x >= 3 Then mPlayMovX = x - 2: tt = MovDownTest()
End If
If tt = False Then
If x <= mPlayKuan - 1 Then mPlayMovX = x + 1: tt = MovDownTest()
End If
If tt = False Then
If x <= mPlayKuan - 2 Then mPlayMovX = x + 2: tt = MovDownTest()
End If
If tt = False Then
b0 = mErsBar(0): b1 = mErsBar(1)
For j = 0 To 5
mErsBar(j) = mErsBar(j + 2)
Next j
mErsBar(6) = b0: mErsBar(7) = b1
mPlayMovX = x
End If
End Sub
Private Sub NewStart()
'为各公用数组变量赋初始值并开始新游戏的子程序
Dim i As Long, j As Long
mPlayX_SIZE = Int(frmErs.picPlay.ScaleWidth / mPlayKuan)
mPlayY_SIZE = Int(frmErs.picPlay.ScaleHeight / mPlayGao)
mPlayBkColor = frmErs.picPlay.BackColor
mNextX_SIZE = Int(frmErs.picNext.ScaleWidth / 5)
mNextY_SIZE = Int(frmErs.picNext.ScaleHeight / 5)
mNextBkColor = frmErs.picNext.BackColor
mErsPD(0, 0) = 0: mErsPD(1, 0) = 1: mErsPD(2, 0) = 2
mErsPD(0, 1) = 7: mErsPD(1, 1) = 8: mErsPD(2, 1) = 3
mErsPD(0, 2) = 6: mErsPD(1, 2) = 5: mErsPD(2, 2) = 4
ReDim mPlayWindow(-1 To mPlayKuan + 2, 1 To mPlayGao + 3) As Long
'运动小窗口数组初始化
For j = 1 To mPlayGao + 3
For i = -1 To mPlayKuan + 2
mPlayWindow(i, j) = -9
Next i
DoEvents
Next j
'清除运动小窗口旧方块构件
For j = 1 To mPlayGao
For i = 1 To mPlayKuan
Call SmallBarPlay(i, j, 0)
mPlayWindow(i, j) = 0
Next i
DoEvents
Next j
End Sub
Private Sub SmallBarPlay(ByVal x As Long, ByVal y As Long, ByVal BarMode As Long)
'运动小窗口内方块构件显示或消隐子程序
Dim DefColor As Long
Dim x1 As Long, y1 As Long
x1 = x * mPlayX_SIZE
y1 = y * mPlayY_SIZE
If BarMode = 0 Then '运动消隐(背景色）
frmErs.picPlay.Line (x1 - mPlayX_SIZE, y1 - mPlayY_SIZE)-(x1, y1), mPlayBkColor, BF
Exit Sub
End If
Select Case BarMode '运动显示
Case 1: DefColor = &HFF00FF '粉红色
Case 2: DefColor = &HFFFF& '黄色
Case 3: DefColor = &HFF00& '绿色
End Select
frmErs.picPlay.Line (x1 - mPlayX_SIZE, y1 - mPlayY_SIZE)-(x1, y1), vbBlack, B
frmErs.picPlay.Line (x1 - mPlayX_SIZE + 1, y1 - mPlayY_SIZE + 1)-(x1 - 1, y1 - 1), DefColor, BF
End Sub
Private Sub SmallBarNext(ByVal x As Long, ByVal y As Long, ByVal BarMode As Long)
'预览小窗口内方块构件显示或消隐子程序
Dim DefColor As Long
Dim x1 As Long, y1 As Long
x1 = x * mNextX_SIZE
y1 = y * mNextY_SIZE
If BarMode = 0 Then '预览消隐(背景色）
frmErs.picNext.Line (x1 - mNextX_SIZE, y1 - mNextY_SIZE)-(x1, y1), mNextBkColor, BF
Exit Sub
End If
Select Case BarMode '预览显示
Case 1: DefColor = &HFF00FF
Case 2: DefColor = &HFFFF&
Case 3: DefColor = &HFF00&
End Select
frmErs.picNext.Line (x1 - mNextX_SIZE, y1 - mNextY_SIZE)-(x1, y1), vbBlack, B
frmErs.picNext.Line (x1 - mNextX_SIZE + 1, y1 - mNextY_SIZE + 1)-(x1 - 1, y1 - 1), DefColor, BF
End Sub
(八) 在工程属性中设置启动对象为Sub Main。
(九) 选择运行，看看这个游戏到底怎么样。
(十) 为获得满意的运行效果，请您对窗体、图片框和标签的大小、位置等作一些适当的细节调整。
附：为使您分析本程序时不至太费时（以至超过您自己现编一个？），现将本模块内各子程序(函数)的层次关系条列如下：
主程序 Main
第一级子程序/函数 (被调用者）
一、BarDef
二、BarViewPlay (1)
三、BarViewNext (2)
四、LineTestAndClear (1、3)
五、MovDownTest
六、MovLeftTest
七、MovRightTest
八、MovTurnTest (五、1)
九、NewStart (1)
第二级子程序
1、SmallBarPlay
2、SmallBarNext
3、LocMe
提示：如尚有不明之处，可与作者联系并讨论。
作 者： 梁远海
福建省南平市延平区大洋学区
E-Mail: dayang@k12.com.cn
|
|
发表于 2006-7-5 15:39:00
楼主