frmmain.frm

用VB实现的俄罗斯方块游戏

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "俄罗斯方块"
   ClientHeight    =   6360
   ClientLeft      =   45
   ClientTop       =   225
   ClientWidth     =   4800
   Icon            =   "frmMain.frx":0000
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   424
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   320
   StartUpPosition =   2  '屏幕中心
   Begin VB.Timer tmrCheckKey 
      Interval        =   120
      Left            =   4200
      Top             =   1440
   End
   Begin VB.Timer tmrDelay 
      Enabled         =   0   'False
      Interval        =   100
      Left            =   3840
      Top             =   1440
   End
   Begin VB.PictureBox picBricks 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   300
      Left            =   3360
      Picture         =   "frmMain.frx":0E42
      ScaleHeight     =   300
      ScaleWidth      =   2400
      TabIndex        =   7
      Top             =   6000
      Visible         =   0   'False
      Width           =   2400
   End
   Begin VB.PictureBox picAnim 
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   1500
      Left            =   3360
      Picture         =   "frmMain.frx":3406
      ScaleHeight     =   1500
      ScaleWidth      =   1680
      TabIndex        =   6
      Top             =   4200
      Width           =   1680
   End
   Begin VB.PictureBox picNextBrick 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      Height          =   1260
      Left            =   3360
      ScaleHeight     =   80
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   80
      TabIndex        =   1
      Top             =   120
      Width           =   1260
   End
   Begin VB.PictureBox picSpace 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      Height          =   6060
      Left            =   120
      ScaleHeight     =   400
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   200
      TabIndex        =   0
      Top             =   120
      Width           =   3060
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "级别："
      Height          =   180
      Left            =   3360
      TabIndex        =   5
      Top             =   2520
      Width           =   540
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "分数："
      Height          =   180
      Left            =   3360
      TabIndex        =   4
      Top             =   1680
      Width           =   540
   End
   Begin VB.Label lblLevel 
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   375
      Left            =   3360
      TabIndex        =   3
      Top             =   2760
      Width           =   1260
   End
   Begin VB.Label lblScore 
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      Caption         =   "0"
      Height          =   375
      Left            =   3360
      TabIndex        =   2
      Top             =   1920
      Width           =   1260
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'________________________________________________________________________________
'
' 全局声明
'________________________________________________________________________________
'
Option Explicit

' API函数声明
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
    ByVal x As Long, ByVal y As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_RETURN = &HD
Private Const VK_SPACE = &H20
Private Const VK_UP = &H26
Private Const VK_DOWN = &H28
Private Const VK_LEFT = &H25
Private Const VK_RIGHT = &H27
Private Const VK_ESCAPE = &H1B

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" ( _
    ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Const SND_ASYNC = &H1

' 全局常量
Private Const MAX_BRICK_ID As Integer = 6
Private Const MAX_Y As Integer = 23
Private Const MAX_X As Integer = 9

' 全局变量
Private Brick(MAX_BRICK_ID, 3, 3, 3) As Boolean
Private Rate(MAX_BRICK_ID) As Integer

Private Space(MAX_Y, MAX_X) As Integer
Private CurrX As Integer
Private CurrY As Integer
Private CurrID As Integer
Private CurrDir As Integer
Private NextID As Integer
Private NextDir As Integer

Private Level As Integer
Private Score As Long

Private Playing As Boolean


'________________________________________________________________________________
'
' 窗体与控件事件
'________________________________________________________________________________
'
' 窗体加载
Private Sub Form_Load()
    Me.Show
    InitGame
End Sub

' 时间事件
Private Sub tmrDelay_Timer()
    If Not FallBrick Then
        If CurrY = MAX_Y Then
            MsgBox "你输了！", vbInformation Or vbOKOnly, "俄罗斯方块"
            End
        End If
        BrickFallen
        LoadBrick
    End If
End Sub

' 时间事件
Private Sub tmrCheckKey_Timer()
    Static LastKey As Long
    Dim CurrKey As Long
    
    If Playing Then
        If GetAsyncKeyState(VK_DOWN) Then
            FallBrick
            CurrKey = VK_DOWN
        ElseIf GetAsyncKeyState(VK_LEFT) Then
            MoveBrick -1
            CurrKey = VK_LEFT
        ElseIf GetAsyncKeyState(VK_RIGHT) Then
            MoveBrick 1
            CurrKey = VK_RIGHT
        Else
            If GetAsyncKeyState(VK_RETURN) Then
                tmrDelay.Enabled = False
                Playing = False
            ElseIf GetAsyncKeyState(VK_UP) Or GetAsyncKeyState(VK_SPACE) Then
                RotateBrick True
            ElseIf GetAsyncKeyState(VK_ESCAPE) Then
                End
            End If
            CurrKey = 0
        End If
    Else
        If GetAsyncKeyState(VK_RETURN) Then
            tmrDelay.Enabled = True
            Playing = True
        ElseIf GetAsyncKeyState(VK_LEFT) Then
            If Level > 0 Then Level = Level - 1
            SetDelayTime Level
        ElseIf GetAsyncKeyState(VK_RIGHT) Then
            If Level < 9 Then Level = Level + 1
            SetDelayTime Level
        ElseIf GetAsyncKeyState(VK_ESCAPE) Then
            End
        End If
        CurrKey = 0
    End If
    If CurrKey <> 0 And CurrKey = LastKey Then
        tmrCheckKey.Interval = 25
    Else
        tmrCheckKey.Interval = 75
    End If
    LastKey = CurrKey
End Sub


'________________________________________________________________________________
'
' 游戏初始化
'________________________________________________________________________________
'
' 初始化
Private Sub InitGame()
    
    Playing = False
   
    Randomize Timer
    
    Score = 0
    Level = 0
    SetDelayTime Level
    
    If Not ReadData Then
        MsgBox "载入数据出错！", vbInformation Or vbOKOnly, "俄罗斯方块"
        End
    End If
    
    NextID = Int(Rnd * (MAX_BRICK_ID + 1))
    NextDir = Int(Rnd * 4)
    LoadBrick
    
End Sub

' 读取数据
Private Function ReadData() As Boolean
    On Error GoTo FileErr
    Dim FileNum As Integer
    FileNum = FreeFile
    Open "Brick.dat" For Input As FileNum
    
    Dim i As Integer, j As Integer, y As Integer, x As Integer
    
    Dim b As Integer