module1.bas

具有声效的用VB写的俄罗斯方块及源代码

Attribute VB_Name = "Module1"
Option Explicit

Public gstrAppName As String

Public gintShapes(7, 3, 3) As Integer '五种形状的方块.
Public gintCurShape(3, 3)  As Integer '当前的方块.
Public gintBoard(13, 18)  As Integer 'Play view

'当前方块左上角相对Play view的位置.
Public gintCurShapeX As Integer
Public gintCurShapeY As Integer

'下一个方块的序号,即gintShapes第一维的下标.
Public gintNextShape As Integer
Public gintLinesKilled '一共消除的行数,可当分数.
Public gblnPaused '暂停

Public Function CanRotateShape() As Boolean
Dim i As Integer, j As Integer
Dim tmpShape(3, 3) As Integer

For i = 0 To 3
    For j = 0 To 3
        tmpShape(i, j) = gintCurShape(i, j)
    Next j
Next i

Call RotateShape(tmpShape())

For i = 0 To 3
    For j = 0 To 3
        If tmpShape(i, j) = 1 Then
            If gintCurShapeX + i < 0 Or gintCurShapeX + i > UBound(gintBoard, 1) Or _
            gintCurShapeY + j < 0 Or gintCurShapeY + j > UBound(gintBoard, 2) Then
                CanRotateShape = False
                Exit Function
            ElseIf gintBoard(gintCurShapeX + i, gintCurShapeY + j) = 1 Then
                CanRotateShape = False
                Exit Function
            End If
        End If
    Next j
Next i

CanRotateShape = True
End Function

'用当前前景色画gintCurShape
Public Sub DrawCurShape()
Dim i As Integer, j As Integer

For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i

End Sub

Public Sub InitMMCs()
frmMain!MMC1.Notify = False
frmMain!MMC1.Wait = True
frmMain!MMC1.Shareable = False
frmMain!MMC1.DeviceType = "WaveAudio"
frmMain!MMC1.FileName = App.Path & "\TouchBottom.wav"
frmMain!MMC1.Command = "Open"

frmMain!MMC2.Notify = False
frmMain!MMC2.Wait = True
frmMain!MMC2.Shareable = False
frmMain!MMC2.DeviceType = "WaveAudio"
frmMain!MMC2.FileName = App.Path & "\rotating.wav"
frmMain!MMC2.Command = "Open"

frmMain!MMC3.Notify = False
frmMain!MMC3.Wait = True
frmMain!MMC3.Shareable = False
frmMain!MMC3.DeviceType = "WaveAudio"
frmMain!MMC3.FileName = App.Path & "\Killing.wav"
frmMain!MMC3.Command = "Open"

'frmMain!MMC4.Notify = False
'frmMain!MMC4.Wait = True
'frmMain!MMC4.Shareable = False
'frmMain!MMC4.DeviceType = "WaveAudio"
'frmMain!MMC4.FileName = App.Path & "\Moving.wav"
'frmMain!MMC4.Command = "Open"
End Sub

Public Sub TouchBottomSound()
frmMain!MMC1.Command = "Prev"
If frmMain!MMC1.CanPlay Then
    frmMain!MMC1.Command = "Play"
End If
End Sub

Public Sub KillingSound()
frmMain!MMC3.Command = "Prev"
If frmMain!MMC3.CanPlay Then
    frmMain!MMC3.Command = "Play"
'Else
    'MsgBox frmMain!MMC3.ErrorMessage
End If
End Sub


'消除所有完整的一行.
Public Sub KillLine()
Dim i As Integer, j As Integer, k As Integer, l As Integer
Dim intLinesKilled As Integer


intLinesKilled = 0 '尚未消除一行.

For i = UBound(gintBoard, 2) To 0 Step -1
    For j = 0 To UBound(gintBoard, 1)
        If gintBoard(j, i) <> 1 Then Exit For '不是完整的一行.
    Next j
    If j > UBound(gintBoard, 1) Then '碰到完整的一行.
        For k = i To 1 Step -1
            For l = 0 To UBound(gintBoard, 1)
                gintBoard(l, k) = gintBoard(l, k - 1)
            Next l
        Next k
        
        i = i + 1
        intLinesKilled = intLinesKilled + 1
        
        gintLinesKilled = gintLinesKilled + intLinesKilled * 10
        frmMain!lblLinesKilled.Caption = Str(gintLinesKilled)
        
        If gintLinesKilled >= 1500 And gintLinesKilled < 3000 Then
            frmMain!lblLevel.Caption = "中级"
            frmMain!Timer1.Interval = 400
        ElseIf gintLinesKilled >= 3000 Then
            frmMain!lblLevel.Caption = "高级"
            frmMain!Timer1.Interval = 300
        End If
    End If
Next i

'重画Play view.
If intLinesKilled >= 1 Then
    Call KillingSound
    frmMain!PicPlay.Cls
    For i = UBound(gintBoard, 2) To 0 Step -1
        For j = 0 To UBound(gintBoard, 1)
            If gintBoard(j, i) = 1 Then
                frmMain!PicPlay.Line (j, i)-(j + 1, i + 1), , B
            End If
        Next j
    Next i
End If

Call DrawCurShape
End Sub

Public Sub MoveLeft()
Dim i As Integer, j As Integer
Dim lngOldColor As Long

'擦除当前方块所在区域.
lngOldColor = frmMain!PicPlay.FillColor
frmMain!PicPlay.FillColor = frmMain!PicPlay.BackColor
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i

gintCurShapeX = gintCurShapeX - 1

'在新位置重画.
frmMain!PicPlay.FillColor = lngOldColor '恢复原色.
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i


End Sub


Public Sub MoveRight()
Dim i As Integer, j As Integer
Dim lngOldColor As Long

'擦除当前方块所在区域.
lngOldColor = frmMain!PicPlay.FillColor
frmMain!PicPlay.FillColor = frmMain!PicPlay.BackColor
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i

gintCurShapeX = gintCurShapeX + 1

'在新位置重画.
frmMain!PicPlay.FillColor = lngOldColor '恢复原色.
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i


End Sub


'发出移动的声音
Public Sub MovingSound()
frmMain!MMC4.Command = "Prev"
If frmMain!MMC4.CanPlay Then
    frmMain!MMC4.Command = "Play"
End If
End Sub

'旋转一个方块.
Public Sub RotateShape(intShape() As Integer)
Dim i As Integer, j As Integer
Dim tmpShape(3, 3) As Integer

'Rotate tmpShape
For i = 0 To 3
    For j = 0 To 3
        tmpShape(j, 3 - i) = intShape(i, j)
    Next j
Next i

'令gintCurShape = tmpShape
For i = 0 To 3
    For j = 0 To 3
        intShape(i, j) = tmpShape(i, j)
    Next j
Next i

End Sub

'从7种方块中随机选择一种方块成为当前的方块.
Public Sub NewCurShape()
Dim i As Integer, j As Integer

'产生新的方块.
For i = 0 To 3
    For j = 0 To 3
        gintCurShape(i, j) = gintShapes(gintNextShape, i, j)
    Next j
Next i

gintNextShape = Int(7 * Rnd)

frmMain!PicPreview.Cls
'预视下一个方块.
For i = 0 To 3
    For j = 0 To 3
        If gintShapes(gintNextShape, i, j) = 1 Then
            frmMain!PicPreview.Line (i + 1, j + 1)-(i + 2, j + 2), , B
        End If
    Next j
Next i


'令新方块在Play view的上方中央显示.
gintCurShapeX = Int(frmMain!PicPlay.ScaleWidth / 2) - 1
gintCurShapeY = 0
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            frmMain!PicPlay.Line (gintCurShapeX + i, _
            gintCurShapeY + j)-(gintCurShapeX + i + 1, gintCurShapeY + j + 1), , B
        End If
    Next j
Next i

'判断是否已Game over.
For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 And _
        gintBoard(gintCurShapeX + i, gintCurShapeY + j) = 1 Then
            
            frmMain!Timer1.Enabled = False '先禁止Timer事件.
            If gintLinesKilled < 1500 Then
                MsgBox "你的反应太慢了!" & vbCrLf & vbCrLf & "按确定承认你是一个笨蛋!", vbOKOnly + vbInformation, "游戏结束"
            ElseIf gintLinesKilled >= 3000 And gintLinesKilled < 4500 Then
                MsgBox "水平可以,继续提高手脑协调能力!", vbOKOnly + vbInformation, "游戏结束"
            ElseIf gintLinesKilled >= 4500 And gintLinesKilled < 6000 Then
                MsgBox "高手!我太佩服了!如你是一个MM, 我愿以身相许;-)", vbOKOnly + vbInformation, "游戏结束"
            Else
                MsgBox "以你的水平,已经可以独步游戏界了!", vbOKOnly + vbInformation, "游戏结束"
            End If
            
            Call ResetEnv '重置环境.
        
        End If
    Next j
Next i

End Sub

Public Sub InitShapes()
'  0
'  0
'  0
'  0
gintShapes(0, 0, 0) = 0
gintShapes(0, 0, 1) = 1
gintShapes(0, 0, 2) = 0
gintShapes(0, 0, 3) = 0

gintShapes(0, 1, 0) = 0
gintShapes(0, 1, 1) = 1
gintShapes(0, 1, 2) = 0
gintShapes(0, 1, 3) = 0

gintShapes(0, 2, 0) = 0
gintShapes(0, 2, 1) = 1
gintShapes(0, 2, 2) = 0
gintShapes(0, 2, 3) = 0

gintShapes(0, 3, 0) = 0
gintShapes(0, 3, 1) = 1
gintShapes(0, 3, 2) = 0
gintShapes(0, 3, 3) = 0

' 00
' 00
gintShapes(1, 0, 0) = 0
gintShapes(1, 0, 1) = 0
gintShapes(1, 0, 2) = 0
gintShapes(1, 0, 3) = 0

gintShapes(1, 1, 0) = 0
gintShapes(1, 1, 1) = 1
gintShapes(1, 1, 2) = 1
gintShapes(1, 1, 3) = 0

gintShapes(1, 2, 0) = 0
gintShapes(1, 2, 1) = 1
gintShapes(1, 2, 2) = 1
gintShapes(1, 2, 3) = 0

gintShapes(1, 3, 0) = 0
gintShapes(1, 3, 1) = 0
gintShapes(1, 3, 2) = 0
gintShapes(1, 3, 3) = 0

' 0
' 0
' 00
gintShapes(2, 0, 0) = 0
gintShapes(2, 0, 1) = 1
gintShapes(2, 0, 2) = 0
gintShapes(2, 0, 3) = 0

gintShapes(2, 1, 0) = 0
gintShapes(2, 1, 1) = 1
gintShapes(2, 1, 2) = 0
gintShapes(2, 1, 3) = 0

gintShapes(2, 2, 0) = 0
gintShapes(2, 2, 1) = 1
gintShapes(2, 2, 2) = 1
gintShapes(2, 2, 3) = 0

gintShapes(2, 3, 0) = 0
gintShapes(2, 3, 1) = 0
gintShapes(2, 3, 2) = 0
gintShapes(2, 3, 3) = 0

' 0
' 00
'  0
gintShapes(3, 0, 0) = 0
gintShapes(3, 0, 1) = 1
gintShapes(3, 0, 2) = 0
gintShapes(3, 0, 3) = 0

gintShapes(3, 1, 0) = 0
gintShapes(3, 1, 1) = 1
gintShapes(3, 1, 2) = 1
gintShapes(3, 1, 3) = 0

gintShapes(3, 2, 0) = 0
gintShapes(3, 2, 1) = 0
gintShapes(3, 2, 2) = 1
gintShapes(3, 2, 3) = 0

gintShapes(3, 3, 0) = 0
gintShapes(3, 3, 1) = 0
gintShapes(3, 3, 2) = 0
gintShapes(3, 3, 3) = 0

'  0
' 000
gintShapes(4, 0, 0) = 0
gintShapes(4, 0, 1) = 0
gintShapes(4, 0, 2) = 0
gintShapes(4, 0, 3) = 0

gintShapes(4, 1, 0) = 0
gintShapes(4, 1, 1) = 1
gintShapes(4, 1, 2) = 0
gintShapes(4, 1, 3) = 0

gintShapes(4, 2, 0) = 1
gintShapes(4, 2, 1) = 1
gintShapes(4, 2, 2) = 1
gintShapes(4, 2, 3) = 0

gintShapes(4, 3, 0) = 0
gintShapes(4, 3, 1) = 0
gintShapes(4, 3, 2) = 0
gintShapes(4, 3, 3) = 0

'  0
' 00
' 0
gintShapes(5, 0, 0) = 0
gintShapes(5, 0, 1) = 0
gintShapes(5, 0, 2) = 1
gintShapes(5, 0, 3) = 0

gintShapes(5, 1, 0) = 0
gintShapes(5, 1, 1) = 1
gintShapes(5, 1, 2) = 1
gintShapes(5, 1, 3) = 0

gintShapes(5, 2, 0) = 0
gintShapes(5, 2, 1) = 1
gintShapes(5, 2, 2) = 0
gintShapes(5, 2, 3) = 0

gintShapes(5, 3, 0) = 0
gintShapes(5, 3, 1) = 0
gintShapes(5, 3, 2) = 0
gintShapes(5, 3, 3) = 0

' 0
' 0
'00
gintShapes(6, 0, 0) = 0
gintShapes(6, 0, 1) = 0
gintShapes(6, 0, 2) = 1
gintShapes(6, 0, 3) = 0

gintShapes(6, 1, 0) = 0
gintShapes(6, 1, 1) = 0
gintShapes(6, 1, 2) = 1
gintShapes(6, 1, 3) = 0

gintShapes(6, 2, 0) = 0
gintShapes(6, 2, 1) = 1
gintShapes(6, 2, 2) = 1
gintShapes(6, 2, 3) = 0

gintShapes(6, 3, 0) = 0
gintShapes(6, 3, 1) = 0
gintShapes(6, 3, 2) = 0
gintShapes(6, 3, 3) = 0
End Sub

'判断当前方块可否左移.
Public Function CanMoveLeft() As Boolean
Dim i As Integer, j As Integer

For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            If gintCurShapeX + i <= 0 Then '已在Play view在最左边.
                CanMoveLeft = False
                Exit Function
            ElseIf gintBoard(gintCurShapeX + i - 1, gintCurShapeY + j) = 1 Then
                CanMoveLeft = False
                Exit Function
            End If
        End If
    Next j
Next i

CanMoveLeft = True

End Function

'判断当前方块可否右移.
Public Function CanMoveRight() As Boolean
Dim i As Integer, j As Integer

For i = 0 To 3
    For j = 0 To 3
        If gintCurShape(i, j) = 1 Then
            If gintCurShapeX + i >= UBound(gintBoard, 1) Then '已在Play view在最右边.
                CanMoveRight = False
                Exit Function
            ElseIf gintBoard(gintCurShapeX + i + 1, gintCurShapeY + j) = 1 Then
                CanMoveRight = False
                Exit Function
            End If
        End If
    Next j
Next i

CanMoveRight = True

End Function

'判断当前方块可否下移.
Public Function CanMoveDown() As Boolean
Dim i As Integer, j As Integer

For i = 0 To 3
    For j = 0 To 3
        'Debug.Print gintCurShape(i, j)
        If gintCurShape(i, j) = 1 Then
            If gintCurShapeY + j + 1 > UBound(gintBoard, 2) Then '已在Play view在最下边.
                CanMoveDown = False
                Exit Function
            ElseIf gintBoard(gintCurShapeX + i, gintCurShapeY + j + 1) = 1 Then
                CanMoveDown = False
                Exit Function
            End If
        End If
    Next j
Next i

CanMoveDown = True
End Function

'把当前方块向下移
Public Function MoveDown() As Boolean
Dim i As Integer, j As Integer
Dim lngOldColor As Long

'擦除当前方块所在区域.
lngOldColor = frmMain!PicPlay.FillColor
frmMain!PicPlay.FillColor = frmMain!PicPlay.BackColor
Call DrawCurShape

gintCurShapeY = gintCurShapeY + 1

'在新位置重画.
frmMain!PicPlay.FillColor = lngOldColor '恢复原色.
Call DrawCurShape
End Function

'重新设置环境.
Public Sub ResetEnv()
Dim i As Integer, j As Integer

'清除Play view.
For i = 0 To 13
    For j = 0 To 18
        gintBoard(i, j) = 0
    Next j
Next i
gintNextShape = Int(Rnd * 7)
gintLinesKilled = 0
gblnPaused = False

frmMain!PicPlay.Cls
frmMain!PicPreview.Cls
frmMain!lblLevel.Caption = "初级"
frmMain!lblLinesKilled.Caption = gintLinesKilled
frmMain!cmdStart.Caption = "开始(&S)"
frmMain!cmdStop.Enabled = False

frmMain.Caption = gstrAppName & "--停止"
frmMain!Timer1.Interval = 500
frmMain!Timer1.Enabled = False

End Sub

Public Sub RotatingSound()
frmMain!MMC2.Command = "Prev"
If frmMain!MMC2.CanPlay Then
    frmMain!MMC2.Command = "Play"
End If

End Sub