tetris.ctl

一个俄罗斯方块游戏

VERSION 5.00
Object = "{27395F88-0C0C-101B-A3C9-08002B2F49FB}#1.1#0"; "PICCLP32.OCX"
Begin VB.UserControl Tetris 
   CanGetFocus     =   0   'False
   ClientHeight    =   8265
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4335
   Picture         =   "Tetris.ctx":0000
   ScaleHeight     =   551
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   289
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   2115
      Top             =   3810
   End
   Begin PicClip.PictureClip picBlocks 
      Left            =   1080
      Top             =   2760
      _ExtentX        =   4630
      _ExtentY        =   661
      _Version        =   393216
      Cols            =   7
      Picture         =   "Tetris.ctx":745B6
   End
End
Attribute VB_Name = "Tetris"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*======================================================================================== <Description>
'* 模块: <Tetris>
'* 说明:
'*
'*
'* 作者: <孙海文>   <北邮电信网络资源部>   <2002-7-27 13:59:44>
'*
'* 修改记录:
'* 作者     日期        说明              修改原因
'*======================================================================================== </Description>

Option Explicit

Private Declare Sub Sleep Lib "KERNEL32" (ByVal dwMilliseconds As Long)
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Const c_MaxCol = 9   '* The Width of the Panel, in Blocks
Const c_MaxRow = 19  '* The Height of the Panel, in Blocks
Const c_BlockWidth = 26   '* The width of a Block, in Pixels
Const c_BlockHeight = 26  '* The height of a block, in Pixels
Const c_TopMargin = 15    '* the top margin of the panel, in Pixels
Const c_LeftMargin = 15   '* the left margin of the panel, in Pixels


Private m_Panel(c_MaxCol, c_MaxRow) As Byte

Public Enum btt_GameState
   btt_gs_Idle = 0
   btt_gs_Playing
   btt_gs_Paused
End Enum

Private m_State As btt_GameState

Private m_Level As Long
Private m_ActTetris As tagActiveTetris

Public Event GameStart()
Public Event GamePause()
Public Event GameResume()
Public Event GameOver()
Public Event TetrisDrop()
Public Event RowsClear(ByVal nLines As Long)
Public Event RowsGrow(ByVal nLines As Long)

Public Property Get State() As btt_GameState
   State = m_State
End Property

Public Property Get PanelWidth() As Long
   PanelWidth = c_MaxCol + 1
End Property


Public Property Get PanelHeight() As Long
   PanelHeight = c_MaxRow + 1
End Property


Public Sub GetActTetris(ByRef nTetris As Long, ByRef nAngle As Long, ByRef nLeft As Long, ByRef nTop As Long)
   With m_ActTetris
      nTetris = .TetIndex
      nAngle = .Angle
      nLeft = .Left
      nTop = .Top
   End With
End Sub


'* move the active tetris
'* return:
'*    o True if the tetris moved
'*    o False if the tetris can not move to specified position
Private Function pMoveActTetris(ByVal DX As Long, ByVal DY As Long) As Boolean
   If m_State <> btt_gs_Playing Then
      pMoveActTetris = False
      Exit Function
   End If
   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      pMoveActTetris = False
      Exit Function
   End If
   
   Dim bCanMove As Boolean
   With m_ActTetris
      bCanMove = CanPlaceTetris(.TetIndex, .Angle, .Left + DX, .Top + DY, m_Panel)
   End With
   
   If bCanMove Then
      pMoveActTetris = True
      
      With m_ActTetris
         Call pHideTetris(.TetIndex, .Angle, .Left, .Top)
         .Left = .Left + DX
         .Top = .Top + DY
         Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
      End With
      
   Else
      pMoveActTetris = False
   End If
End Function


Public Function MoveLeft() As Boolean
   MoveLeft = pMoveActTetris(-1, 0)
End Function


Public Function MoveRight() As Boolean
   MoveRight = pMoveActTetris(1, 0)
End Function


Public Function MoveDown() As Boolean
   MoveDown = pMoveActTetris(0, 1)
End Function


'* DropDown the active tetris
'* Return:
'*    o True the active tetris dropped down
'*    o False there is none active tetris
Public Function DropDown() As Boolean
   If m_State <> btt_gs_Playing Then
      DropDown = False
      Exit Function
   End If

   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      DropDown = False
      Exit Function
   End If
   
   With m_ActTetris
      Dim I As Long
      I = 1
      Do While CanPlaceTetris(.TetIndex, .Angle, .Left, .Top + I, m_Panel)
         I = I + 1
      Loop
      
      Call pHideTetris(.TetIndex, .Angle, .Left, .Top)
      .Top = .Top + I - 1
      
      Call pActTetrisDroped
   End With
   
   DropDown = True
End Function


'* Turn the active tetris
'* Return:
'*    o True the active tetris turned
'*    o False the active tetris can not be turned
Private Function pTurnActTetris(ByVal DA As Long) As Boolean
   If m_State <> btt_gs_Playing Then
      pTurnActTetris = False
      Exit Function
   End If
   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      pTurnActTetris = False
      Exit Function
   End If

   Dim bCanMove As Boolean, nNewAngle As Long
   nNewAngle = (m_ActTetris.Angle + DA) Mod 4
   If nNewAngle < 0 Then nNewAngle = nNewAngle + 4
   
   With m_ActTetris
      bCanMove = CanPlaceTetris(.TetIndex, nNewAngle, .Left, .Top, m_Panel)
   End With
   
   pTurnActTetris = bCanMove
   
   If bCanMove Then
      With m_ActTetris
         Call pHideTetris(.TetIndex, .Angle, .Left, .Top)
         .Angle = nNewAngle
         Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
      End With
   End If
End Function


Public Function TurnLeft() As Boolean
   TurnLeft = pTurnActTetris(1)
End Function


Public Function TurnRight() As Boolean
   TurnRight = pTurnActTetris(-1)
End Function


'* set the current active tetris, the active tetrus can be set only when
'* the game is started.
Public Function SetActTetris(ByVal vNew As Long) As Boolean
   If m_State <> btt_gs_Playing Then
      SetActTetris = False
      Exit Function
   End If

   With m_ActTetris
      Call pHideTetris(.TetIndex, .Angle, .Left, .Top)
   End With
   
   If Not pIsValidTetris(vNew) Then
      m_ActTetris.TetIndex = -1
      Exit Function
   End If
   
   Dim nTetRow As Long, nTetCol As Long, nRow As Long, nCol As Long
   
   Dim nTop As Long, bValid As Boolean
   nTop = 0
   Do Until CanPlaceTetris(vNew, 0, 3, nTop, m_Panel)
      nTop = nTop - 1
   Loop
   
   With m_ActTetris
      .TetIndex = vNew
      .Angle = 0
      .Left = 3
      .Top = nTop
   
      Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
   End With
   
   SetActTetris = True
   
   Dim nInterval As Long
   nInterval = GetIntervalOfLevel(m_Level)
   If nInterval < 400 Then
      nInterval = 400
   End If
   Timer1.Interval = nInterval
End Function


Public Sub BeginGame()
   If m_State <> btt_gs_Idle Then
      Exit Sub
   End If
   
   m_State = btt_gs_Playing
   Timer1.Enabled = True
   
   RaiseEvent GameStart
End Sub


Public Sub PauseGame()
   If m_State <> btt_gs_Playing Then
      Exit Sub
   End If
   
   m_State = btt_gs_Paused
   Timer1.Enabled = False
   
   RaiseEvent GamePause
End Sub
Public Sub ResumeGame()
   If m_State <> btt_gs_Paused Then
      Exit Sub
   End If
   
   m_State = btt_gs_Playing
   Timer1.Enabled = True
   
   RaiseEvent GameResume
End Sub


Public Sub EndGame()
   If m_State <> btt_gs_Playing Then
      Exit Sub
   End If
   
   m_State = btt_gs_Idle
   Timer1.Enabled = False
   
   With m_ActTetris
      If pIsValidTetris(.TetIndex) Then
         Call PlaceTetris(.TetIndex, .Angle, .Left, .Top, m_Panel)
      End If
   End With
   m_ActTetris.TetIndex = -1
End Sub


Public Property Get Level() As Long
   Level = m_Level
End Property
Public Property Let Level(ByVal vNew As Long)
   If vNew < 0 Then
      vNew = 0