‘FuangKuai(FuangKuai.bas)
Option Explicit
Public Type FangKuai
Info(1 To 4, 1 To 4) As Integer '存储每个方块的信息,用4*4的格子表示方块
PicType As Integer '方块的图型,有效值1 到4
End Type
Public FKArray(1 To 6, 1 To 4) As FangKuai
Public ImageFKArray(12 * 19) As Integer '当前方块
Public BackImageFKArray(12 * 19) As Integer '备份方块
Public ImageBackFKArray(12 * 19) As Integer '背景图形
Public gFKTypeX '当前的方块类型
Public gFKTypeY
Public gFKTypePicType
Public getLine As Integer '存储玩家已经消掉的行数
Public TimeInterVal1 'timer 控件的interval 值
Public TimeInterVal2
Public TimerInterVal3
Public TimerInterVal4
Public FKChangeTypeNum '记录方块的变型方式,1同向变型,2随机变型
'显示方块
Public Sub VisibleFK()
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
Form1!ImageFK(tem).Visible = True
End If
Next n
Next m
End Sub
Public Sub DisVisibleFK()
'开始游戏,visible=false所有方块
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
Form1!ImageFK(tem).Visible = False
Next n
Next m
VisibleBackImg
End Sub
'方块下移一行
Public Sub FKMoveNext()
Dim m
Dim n
Dim tem
DisVisibleFK
'清空备份数组
CleanFKBack
'复制数据到备份数组
For m = 1 To 19
If m = 19 Then
Exit For
End If
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
BackImageFKArray(tem + 12) = 1
ImageFKArray(tem) = 0
End If
Next n
Next m
'清空当前数组
CleanFK
'拷备备份数组到当前数组
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageFKArray(tem) = BackImageFKArray(tem)
Next n
Next m
VisibleFK
End Sub
'清除存放方块的东西
Public Sub CleanFK()
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageFKArray(tem) = 0
Next n
Next m
End Sub
'清空备份的数组
Public Sub CleanFKBack()
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
BackImageFKArray(tem) = 0
Next n
Next m
End Sub
Public Sub FKMoveLeft()
Dim m
Dim n
Dim tem
Dim temX
Dim temY
'找着存放方块的左上角格子的坐标值
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
temX = m
GoTo FindtemY
End If
Next n
Next m
FindtemY:
For m = 1 To 12
For n = 1 To 19
tem = (n - 1) * 12 + m
If ImageFKArray(tem) = 1 Then
temY = m
GoTo FindOK
End If
Next n
Next m
FindOK:
'方块左边不为空
If temY = 1 Then Exit Sub
For m = 1 To 19
For n = 1 To 11
tem = (m - 1) * 12 + n
If ImageBackFKArray(tem) = 1 And ImageFKArray(tem + 1) = 1 Then
Exit Sub
End If
Next n
Next m
'清除备份数组
CleanFKBack
'备份数组
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If (n - 1) = 0 And ImageFKArray(tem) = 1 Then
Exit Sub
End If
If ImageFKArray(tem) = 1 Then
BackImageFKArray(tem - 1) = 1
End If
Next n
Next m
'清空当前数组
CleanFK
'拷备备份数组到当前数组
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageFKArray(tem) = BackImageFKArray(tem)
Next n
Next m
DisVisibleFK
VisibleFK
End Sub
Public Sub FKMoveRight()
Dim m
Dim n
Dim tem
Dim temX
Dim temY
'得到方块右上角的坐标
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
temX = m
End If
GoTo FindtemY
Next n
Next m
FindtemY:
For m = 1 To 12
For n = 1 To 19
tem = (n - 1) * 12 + m
If ImageFKArray(tem) = 1 Then
temY = m
End If
Next n
GoTo FindOK
Next m
FindOK:
'到最右了,不能移动了
If temY = 12 Then Exit Sub
'如果右边的格子不为空
For m = 1 To 19
For n = 2 To 12
tem = (m - 1) * 12 + n
If ImageBackFKArray(tem) = 1 And ImageFKArray(tem - 1) = 1 Then
Exit Sub
End If
Next n
Next m
'清除备份数组
CleanFKBack
'备份数组
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If n = 12 And ImageFKArray(tem) = 1 Then
Exit Sub
End If
If ImageFKArray(tem) = 1 Then
BackImageFKArray(tem + 1) = 1
End If
Next n
Next m
'清空当前数组
CleanFK
'拷备备份数组到当前数组
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageFKArray(tem) = BackImageFKArray(tem)
Next n
Next m
DisVisibleFK
VisibleFK
End Sub
'方块变型
Public Sub FKChangeType()
Dim m
Dim n
Dim tem
Dim getTypeY
Dim temX '存放当前方块左上角坐标X
Dim temY ''''''''''''''''''''''''Y
Dim TTT
Static aa As Long
aa = gFKTypeY '变量胡开始写了
If CanMoveNext = 0 Then
Exit Sub
End If
If FKChangeTypeNum = 1 Then
'正向变型
getTypeY = ((aa) Mod 4) + 1
Else
'不规则变型
getTypeY = ((Int(Rnd * 10)) Mod 4) + 1
'方块变型,得到一个不同于gFKTypeY的值就可
While getTypeY = gFKTypeY
getTypeY = ((Int(Rnd * 10)) Mod 4) + 1
Wend
End If
gFKTypeY = getTypeY
'清除备份数组
CleanFKBack
'找着存放方块的左上角格子的坐标值
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
temX = m
GoTo FindtemY
End If
Next n
Next m
FindtemY:
For m = 1 To 12
For n = 1 To 19
tem = (n - 1) * 12 + m
If ImageFKArray(tem) = 1 Then
temY = m
GoTo FindOK
End If
Next n
Next m
FindOK:
'得到temx,temy
DisVisibleFK
CleanFK
'重显方块
For m = temX To temX + 3
For n = temY To temY + 3
Debug.Print gFKTypeX
Debug.Print gFKTypeY
If FKArray(gFKTypeX, gFKTypeY).Info(m - temX + 1, n - temY + 1) = 1 Then
tem = (m - 1) * 12 + n
ImageFKArray(tem) = 1
End If
Next n
Next m
VisibleFK
End Sub
'生成下一个方块
Public Sub GetNext()
Form1!Timer.Interval = TimerInterVal4
Randomize '在调用 Rnd 之前，先使用无参数的 Randomize 语句初始化随机数生成器，该生成器具有根据系统计时器得到的种子。
gFKTypeX = ((Int(Rnd * 10)) Mod 6) + 1 '当前的方块类型
gFKTypeY = ((Int(Rnd * 10)) Mod 4) + 1
gFKTypePicType = ((Int(Rnd * 10)) Mod 4) + 1
Dim FKTypeX
Dim FKTypeY
Dim FKtypePicType
Dim CanMovNext
Dim tem
Dim temX
Dim temY
Dim TTT '实现想不出来什么好名字了
FKTypeX = gFKTypeX
FKTypeY = gFKTypeY
FKtypePicType = gFKTypePicType
CleanFK
DisVisibleFK
For temX = 1 To 4
For temY = 1 To 4
If FKArray(FKTypeX, FKTypeY).Info(temX, temY) = 1 Then
TTT = (temX - 1) * 12 + temY + 4
Form1!ImageFK(TTT).Visible = True
ImageFKArray(TTT) = 1
End If
Next temY
Next temX
'调用显示方块的东西
VisibleFK
VisibleBackImg
If CanMoveNext = 0 Then
Dead
End If
End Sub
Public Sub DrawNextFK()
Dim m
Dim n
Dim tem
'备份当前的图型数组
For m = 1 To 12
For n = 1 To 19
tem = (n - 1) * 12 + m
If Form1!ImageFK(tem).Visible = True Then
ImageBackFKArray(tem) = 1
End If
Next n
Next m
CleanFK
GetNext
End Sub
'能下移吗? 返回1能下移,
'反回 2 到了最底行
Public Function CanMoveNext() As Integer
Dim m
Dim n
Dim tem
Dim test As Integer
Dim tem2
test = 0
'到最底行,不能下移
m = 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
test = 0 '到了最低行
GoTo goback
Else
End If
Next n
'没到最底行,但是不下面有方块了,不能再下移了
For m = 1 To 18
For n = 1 To 12
tem2 = m * 12 + n
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 And ImageBackFKArray(tem2) = 1 Then
test = 0
GoTo goback
End If
Next n
Next m
test = 1
goback:
If test = 0 Then
CanMoveNext = 0
Else
CanMoveNext = 1
End If
End Function
'这里要干什么呢?
Public Sub VisibleBackImg()
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageBackFKArray(tem) = 1 Then
Form1!ImageFK(tem).Visible = True
End If
Next n
Next m
End Sub
Public Sub SaveFK()
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
ImageBackFKArray(tem) = 1
End If
Next n
Next m
VisibleBackImg
End Sub
'能消掉一行吗?
'某行满了吗?
Public Sub DisLine()
Dim m
Dim n
Dim tem
Dim s
For m = 1 To 19
s = 0
For n = 1 To 12
tem = (m - 1) * 12 + n
If Form1!ImageFK(tem).Visible = True Then
s = s + 1
End If
Next n
Debug.Print "s=" & s
If s = 12 Then
getLine = getLine + 1 '得份行数加1
DisPlayLine (m) '调用函数消掉每m行
End If
Next m
VisibleBackImg
End Sub
Public Function DisPlayLine(ByVal numLine As Integer) As Integer
Dim m
Dim n
Dim tem
'取消显示满格的一行
For n = 1 To 12
tem = (numLine - 1) * 12 + n
ImageBackFKArray(tem) = 0
Next n
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
If ImageFKArray(tem) = 1 Then
ImageBackFKArray(tem) = 1
End If
Next n
Next m
'方块下移
Dim temArray(12 * 19) As Integer
For m = 1 To numLine - 1
For n = 1 To 12
tem = (m - 1) * 12 + n
Debug.Print tem + 12
temArray(tem + 12) = ImageBackFKArray(tem) '这里有点问题,如果第一行满格了怎么办?不过这种情况能出现吗?
'here is a bug?
'改成+12 OK?
Next '发现错误,应是numline-1
Next
For m = 1 To numLine - 1
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageBackFKArray(tem) = temArray(tem)
Next
Next
DisVisibleFK
VisibleBackImg
End Function
'死了吗?
'这个函数现在没有用了
Public Function IsDead(ByVal numLine As Integer) As Integer
Dim test
If CanMoveNext = 0 And 1 Then
test = 1 '等于1,玩死了
End If
test = 0
IsDead = test
End Function
'游戏失败,玩家死掉了,处理这些东西吧
Public Sub Dead()
Form1!Timer.Enabled = False
MsgBox "游戏结束" & Chr(13) & "您的得分是" & getLine
Form1!lblStart.Visible = True
'do other things
Dim m
Dim n
Dim tem
For m = 1 To 19
For n = 1 To 12
tem = (m - 1) * 12 + n
ImageBackFKArray(tem) = 1
Next n
Next m
VisibleBackImg
CleanFK
CleanFKBack
End Sub
Public Sub MoveNextQuick()
Dim m
Dim n
Dim tem
Form1!Timer.Interval = 1
End Sub
