tetris.ctl

一个俄罗斯方块游戏

   ElseIf vNew > 10 Then
      vNew = 10
   End If
   
   m_Level = vNew
End Property


Private Sub Timer1_Timer()
   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      Exit Sub
   End If
   
   With m_ActTetris
      If CanPlaceTetris(.TetIndex, .Angle, .Left, .Top + 1, m_Panel) Then
         Call pHideTetris(.TetIndex, .Angle, .Left, .Top)
      
         .Top = .Top + 1
         Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
      
         Timer1.Interval = GetIntervalOfLevel(m_Level)
      Else
         Call pActTetrisDroped
      End If
   End With
End Sub


Private Sub UserControl_Initialize()
   modTetrisUtils.Init
   
   m_ActTetris.TetIndex = -1
   
   Call pRedrawPanel
   
   Me.Level = 3
End Sub


Private Sub UserControl_Paint()
   Call pRedrawPanel
   With m_ActTetris
      Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
   End With
End Sub

Private Sub UserControl_Resize()
   UserControl.Width = UserControl.ScaleX(UserControl.Picture.Width, vbHimetric, vbContainerSize)
   UserControl.Height = UserControl.ScaleY(UserControl.Picture.Height, vbHimetric, vbContainerSize)
End Sub


Public Sub ClearPanel()
   Erase m_Panel
   
   Call UserControl_Paint
End Sub


Public Sub SetPanel(Panel() As Byte)
   Dim nCol As Long, nRow As Long
   For nRow = 0 To c_MaxRow
      For nCol = 0 To c_MaxCol
         m_Panel(nCol, nRow) = Panel(nCol, nRow)
      Next
   Next
   
   Call UserControl_Paint
End Sub


Public Sub GetPanel(Panel() As Byte)
   Panel = m_Panel
End Sub


Private Sub pRedrawPanel()
   UserControl.Cls
   
   Dim nCol As Long, nRow As Long, nX As Long, nY As Long
   
   Const HardGray = &H606060
   nX = c_LeftMargin - 1
   For nCol = 1 To c_MaxCol
      nX = nX + c_BlockWidth
      UserControl.Line (nX, c_TopMargin)-Step(0, c_BlockHeight * (c_MaxRow + 1)), HardGray
   Next
   
   nY = c_TopMargin
   For nRow = 0 To c_MaxRow
      nX = c_LeftMargin
      For nCol = 0 To c_MaxCol
         If m_Panel(nCol, nRow) > 0 Then
            On Error Resume Next
            UserControl.PaintPicture picBlocks.GraphicCell(m_Panel(nCol, nRow) - 1), nX, nY
         End If
         nX = nX + c_BlockWidth
      Next
   
      nY = nY + c_BlockHeight
   Next
End Sub


'* Erase the tetris
'* NOTE: the tetris can be partly or full out of the panel
Private Sub pHideTetris(ByVal nTetIndex As Long, ByVal nAngle As Long, ByVal nLeft As Long, ByVal nTop As Long)
   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      Exit Sub
   End If
   
   Dim nCol As Long, nRow As Long, nX As Long, nY As Long
   Dim I As Long
   For I = 0 To 3
      With g_tetrisdata(nTetIndex, nAngle).BlockPos(I)
         nRow = nTop + .Row
         nCol = nLeft + .Col
      End With
      If nRow >= 0 And nRow <= c_MaxRow And _
                  nCol >= 0 And nCol <= c_MaxCol Then
         nX = nCol * c_BlockWidth + c_LeftMargin
         nY = nRow * c_BlockHeight + c_TopMargin
         UserControl.Line (nX, nY)-Step(c_BlockWidth - 2, c_BlockHeight - 2), vbBlack, BF
      End If
   Next
End Sub



'* draw the tetris
'* NOTE: the tetris can be partly or full out of the panel
Private Sub pDrawTetris(ByVal nTetIndex As Long, ByVal nAngle As Long, ByVal nLeft As Long, ByVal nTop As Long)
   If Not pIsValidTetris(m_ActTetris.TetIndex) Then
      Exit Sub
   End If
   
   Dim nCol As Long, nRow As Long, nX As Long, nY As Long
   Dim I As Long
   For I = 0 To 3
      With g_tetrisdata(nTetIndex, nAngle).BlockPos(I)
         nRow = nTop + .Row
         nCol = nLeft + .Col
      End With
      If nRow >= 0 And nRow <= c_MaxRow And _
                  nCol >= 0 And nCol <= c_MaxCol Then
         nX = nCol * c_BlockWidth + c_LeftMargin
         nY = nRow * c_BlockHeight + c_TopMargin
         UserControl.PaintPicture picBlocks.GraphicCell(nTetIndex), nX, nY
      End If
   Next
End Sub



Private Sub pActTetrisDroped()
   With m_ActTetris
      Call pDrawTetris(.TetIndex, .Angle, .Left, .Top)
      Call PlaceTetris(.TetIndex, .Angle, .Left, .Top, m_Panel)
      
      .TetIndex = -1
   End With

   Dim nRow As Long, nCol As Long, bHaveSpace As Boolean
   Dim oClearedRows As New Collection
   For nRow = 0 To c_MaxRow
      bHaveSpace = False
      For nCol = 0 To c_MaxCol
         If m_Panel(nCol, nRow) = 0 Then
            bHaveSpace = True
            Exit For
         End If
      Next
      
      If Not bHaveSpace Then
         oClearedRows.Add nRow
      End If
   Next
   
   If oClearedRows.Count > 0 Then
      Dim nLine As Variant
      Dim I As Long, J As Long, Y As Long
      
      For I = 0 To 4
         For Each nLine In oClearedRows
            Y = nLine * c_BlockHeight + c_TopMargin + I
            For J = 1 To 5
               UserControl.Line (c_LeftMargin, Y)-Step(c_BlockWidth * (c_MaxCol + 1), 0), vbBlack
               Y = Y + 5
            Next
         Next
         Me.PauseGame
         'Sleep 50
         Dim T As Single
         T = Timer + 0.08
         Do While T > Timer
            DoEvents
         Loop
         Me.ResumeGame
      Next
      
      For Each nLine In oClearedRows
         For nRow = nLine To 1 Step -1
            For nCol = 0 To c_MaxCol
               m_Panel(nCol, nRow) = m_Panel(nCol, nRow - 1)
            Next
         Next
         
         For nCol = 0 To c_MaxCol
            m_Panel(nCol, 0) = 0
         Next
      Next
      
      Call pRedrawPanel
   
      RaiseEvent RowsClear(oClearedRows.Count)
      
   End If

   Dim bIsEmpty As Boolean
   bIsEmpty = True
   For nCol = 0 To c_MaxCol
      If m_Panel(nCol, 0) <> 0 Then
         bIsEmpty = False
         Exit For
      End If
   Next
   
   If Not bIsEmpty Then
      Me.EndGame
      RaiseEvent GameOver
      
   Else
      RaiseEvent TetrisDrop
   
      '* restart the timer
      Timer1.Enabled = False
      Timer1.Enabled = True
   End If
End Sub


Public Sub GrowLines(ByVal nLineCount As Long, ByVal nSpacePerLine As Long)
   If nLineCount <= 0 Then
      Exit Sub
   End If
   
   If nSpacePerLine <= 0 Then
      nSpacePerLine = Int(Rnd * c_MaxCol) + 1
   End If

   Dim I As Long, nRow As Long, nCol As Long
   For I = 1 To nLineCount
      For nRow = 1 To c_MaxRow
         For nCol = 0 To c_MaxCol
            m_Panel(nCol, nRow - 1) = m_Panel(nCol, nRow)
         Next
      Next
   
      For nCol = 0 To c_MaxCol
         m_Panel(nCol, c_MaxRow) = Int(Rnd * 7) + 1
      Next
      For nCol = 1 To nSpacePerLine
         m_Panel(Int(Rnd * (c_MaxCol + 1)), c_MaxRow) = 0
      Next
      
      With m_ActTetris
         If pIsValidTetris(.TetIndex) Then
            Do Until CanPlaceTetris(.TetIndex, .Angle, .Left, .Top, m_Panel)
               .Top = .Top - 1
            Loop
         End If
      End With
   Next
   
   Call UserControl_Paint
   
   RaiseEvent RowsGrow(nLineCount)

   Dim bIsEmpty As Boolean
   bIsEmpty = True
   For nCol = 0 To c_MaxCol
      If m_Panel(nCol, 0) <> 0 Then
         bIsEmpty = False
         Exit For
      End If
   Next

   If Not bIsEmpty Then
      Me.EndGame
      RaiseEvent GameOver
   End If
End Sub


Private Function pIsValidTetris(ByVal Tetris As Long) As Boolean
   pIsValidTetris = (Tetris >= 0 And Tetris <= 6)
End Function


Private Function GetIntervalOfLevel(ByVal nLevel As Long) As Long
   Const Interval0 = 1000
   GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Exit Function
   
   Select Case nLevel
   Case 0
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 1
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 2
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 3
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 4
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 5
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 6
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 7
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 8
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 9
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   Case 10
      GetIntervalOfLevel = Interval0 * 0.75 ^ nLevel
   End Select
End Function