Option Explicit
Private Type SmallBoxPos
Row As Integer
Column As Integer
End Type
Const BLOCKSNUMBER = 4
Private Type TetrisBox
Color As Double '??é?
HasStopped As Boolean '·??éê?·?ò??-í￡?1????
SmallBoxInCurrentBlock(1 To 4) As SmallBoxPos 'μ±?°·??é
SmallBoxInNextPos(1 To 4) As SmallBoxPos '??ò???·??é
CurrentRotateState As Integer 'μ±?°μ?Dy×a×′ì?
RotateChangeData(1 To 4, 1 To 4) As SmallBoxPos '??DDDy×a?ùDèòaμ?êy?Y
color1 As Double
End Type
Private CurrentBlock As TetrisBox 'μ±?°·??é
Private Blocks(1 To 7) As TetrisBox '×ü127??·??é
Private IsGameOver As Boolean 'ó??·ê?·??áê?
Dim GameSpeed As Double 'ó??·?ù?è
Dim PreNextBlock As Integer '??ò???·??éDòo?
Dim ll As Integer
Dim cc As Integer
Private Sub InitBlock()
Dim i As Integer, j As Integer, k As Integer
Blocks(1).color1 = 6354664
Blocks(1).Color = 2448643
Blocks(2).color1 = 9435641
Blocks(2).Color = 552560
Blocks(3).color1 = 5831395
Blocks(3).Color = 9455622
Blocks(4).color1 = 9108207
Blocks(4).Color = 3627564
Blocks(5).color1 = 6093558
Blocks(5).Color = 394876
Blocks(6).color1 = 1242854
Blocks(6).Color = 134552
Blocks(7).color1 = 7011066
Blocks(7).Color = 4535619
cc = 0
Range("level").Value = ll
GameSpeed = 0.4
For k = 1 To 7
With Blocks(k)
For i = 1 To 4 '????·??é×??à4??D?·??é
.SmallBoxInCurrentBlock(i).Row = Range("BlockDataArea").Cells(1 + (k - 1) * 5, i).Value
.SmallBoxInCurrentBlock(i).Column = Range("BlockDataArea").Cells(1 + (k - 1) * 5, i + 4).Value
Next
For i = 1 To 4 '124??Dy×a×′ì?
For j = 1 To 4 '124??D?·??é
.RotateChangeData(i, j).Row = Range("BlockDataArea").Cells(i + 1 + (k - 1) * 5, j).Value
.RotateChangeData(i, j).Column = Range("BlockDataArea").Cells(i + 1 + (k - 1) * 5, j + 4).Value
Next
Next
.HasStopped = False
.CurrentRotateState = 1
End With
Next
End Sub
Private Sub CreateNextBlock(TempBlock As TetrisBox)
Dim i As Integer
Randomize
If PreNextBlock = 0 Then
TempBlock = Blocks(Int(1 + 7 * Rnd))
PreNextBlock = (Int(1 + 7 * Rnd))
Else
TempBlock = Blocks(PreNextBlock)
PreNextBlock = (Int(1 + 7 * Rnd))
End If
Range("NextBlockArea").Clear
With Blocks(PreNextBlock)
For i = 1 To BLOCKSNUMBER
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Pattern = xlPatternRectangularGradient
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.RectangleLeft = 0.4
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.RectangleRight = 0.6
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.RectangleTop = 0.4
Range("Nex
tBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.RectangleBottom = 0.6
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.ColorStops.Clear
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.ColorStops.Add(0).Color = .color1
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Interior.Gradient.ColorStops.Add(1).Color = .Color
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("NextBlockArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column - 4).Borders(xlEdgeBottom).Weight = xlThin
Next
End With
With TempBlock
.SmallBoxInNextPos(1) = .SmallBoxInCurrentBlock(1)
.SmallBoxInNextPos(2) = .SmallBoxInCurrentBlock(2)
.SmallBoxInNextPos(3) = .SmallBoxInCurrentBlock(3)
.SmallBoxInNextPos(4) = .SmallBoxInCurrentBlock(4)
End With
End Sub
Private Function CheckIfCanMove(TempBlock As TetrisBox) As Boolean
Dim i As Integer
CheckIfCanMove = True
With TempBlock
For i = 1 To BLOCKSNUMBER
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).ID = "T"
Next
For i = 1 To BLOCKSNUMBER
With Range("GameArea").Cells(.SmallBoxInNextPos(i).Row, .SmallBoxInNextPos(i).Column)
If .Interior.ColorIndex <> xlNone And .ID = "" Then
CheckIfCanMove = False
End If
End With
Next
For i = 1 To BLOCKSNUMBER
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).ID = ""
Range("ccc").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Value = .Color
Next
End With
End Function
Private Function CheckIfGameOver(TempBlock As TetrisBox) As Boolean
Dim i As Integer
IsGameOver = False
With TempBlock
For i = 1 To BLOCKSNUMBER
If .SmallBoxInCurrentBlock(i).Row < 3 Then
IsGameOver = True
End If
Next
End With
End Function
Sub AddScore()
Dim TempScore As Long
TempScore = CLng(Shapes("CurrentScore").TextEffect.Text)
TempScore = TempScore + cc * 100
Shapes("CurrentScore").TextEffect.Text = Format(TempScore, "000000")
If TempScore + 500 - ll * 500 >= 500 Then
ll = ll + 1
GameSpeed = GameSpeed - ll * 0.01
Range("level").Value = ll
End If
End Sub
Private Sub DrawGameArea(TempBlock As TetrisBox)
' ???-ó??·??óò
Dim i As Integer
With TempBlock
For i = 1 To BLOCKSNUMBER
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Clear
Range("ccc").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Clear
' ??μ±?°·??é?ù????óò??3y
.SmallBoxInCurrentBlock(i) = .SmallBoxInNextPos(i)
Next
For i = 1 To BLOCKSNUMBER
Range("ccc").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Value = .Color
Range("cccc").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Value = .color1
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Pattern = xlPatternRectangularGradient
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.RectangleLeft = 0.4
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.RectangleRight = 0.6
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.RectangleTop = 0.2
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.RectangleBottom = 0.7
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.ColorStops.Clear
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.ColorStops.Add(0).Color = .color1
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Interior.Gradient.ColorStops.Add(1).Color = .Color ' ?ú??ò???·??é??óò?-·??é
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Borders(xlEdgeBottom).LineStyle = xlContinuous
Range("GameArea").Cells(.SmallBoxInCurrentBlock(i).Row, .SmallBoxInCurrentBlock(i).Column).Borders(xlEdgeBottom).Weight = xlThin
' ?a·??ééè??ò?ó°
Next
End With
End Sub
Private Sub GoDown(TempBlock As TetrisBox)
Dim i As Integer
With TempBlock
For i = 1 To BLOCKSNUMBER
.SmallBoxInNextPos(i).Row = .SmallBoxInCurrentBlock(i).Row + 1 ' ??ò???D?·??éμ?DDêy?óò?￡??ò??è￥ò?DD
.SmallBoxInNextPos(i).Column = .SmallBoxInCurrentBlock(i).Column ' áD2?±?
Next
End With
If CheckIfCanMove(TempBlock) Then
Call DrawGameArea(TempBlock)
Else
TempBlock.HasStopped = True
Call CheckFullRow
If CheckIfGameOver(TempBlock) Then
IsGameOver = True
End If
End If
End Sub
Private Sub StartGame()
Dim t As Double
Dim CurrentScore As Long
Dim HighScore As Long
Shapes("CurrentScore").TextEffect.Text = Format(0, "000000")
Application.EnableEvents = True
IsGameOver = False
Range("GameArea").Clear
Range("ccc").Clear
Range("cccc").Clear
Cells(21, 21).Activate
Call InitBlock
Call CreateNextBlock(CurrentBlock)
GameSpeed = 0.4
ll = 0
Range("level") = 0
Do While Not IsGameOver '2?ê?ó??·?áê??ò??DD?-?·
Call GoDown(CurrentBlock)
t = Timer
Do While Timer - t < GameSpeed
DoEvents
Loop
If CurrentBlock.HasStopped Then
Call CreateNextBlock(CurrentBlock)
GameSpeed = 0.41 - ll * 0.01
End If
Loop
HighScore = CLng(Shapes("HighScore").TextEffect.Text)
CurrentScore = CLng(Shapes("CurrentScore").TextEffect.Text)
If CurrentScore > HighScore Then
Shapes("HighScore").TextEffect.Text = Shapes("CurrentScore").TextEffect.Text
End If
Call MsgBox("ó??·?áê?")
IsGameOver = True
End Sub
Private Sub StopGame()
IsGameOver = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Integer, c As Integer
Dim i As Integer
Application.EnableEvents = False
If Not IsGameOver And Not CurrentBlock.HasStopped Then
r = Target.Row
c = Target.Column
With CurrentBlock
If c = 22 Then ' ?òóòáD?ó1 DD2?±?
For i = 1 To BLOCKSNUMBER
.SmallBoxInNextPos(i).Row = .SmallBoxInCurrentBlock(i).Row
.SmallBoxInNextPos(i).Column = 1 + .SmallBoxInCurrentBlock(i).Column
Next
If CheckIfCanMove(CurrentBlock) Then
Call DrawGameArea(CurrentBlock)
End If
ElseIf c = 20 Then ' ?ò×óáD??ò?DD2?±?
For i = 1 To BLOCKSNUMBER
.SmallBoxInNextPos(i).Row = .SmallBoxInCurrentBlock(i).Row
.SmallBoxInNextPos(i).Column = .SmallBoxInCurrentBlock(i).Column - 1
Next
If CheckIfCanMove(CurrentBlock) Then
Call DrawGameArea(CurrentBlock)
End If
ElseIf r = 20 Then ' ?òé??üDy×a
For i = 1 To BLOCKSNUMBER
.SmallBoxInNextPos(i).Row = .SmallBoxInCurrentBlock(i).Row + .RotateChangeData(.CurrentRotateState, i).Row
.SmallBoxInNextPos(i).Column = .SmallBoxInCurrentBlock(i).Column + .RotateChangeData(.CurrentRotateState, i).Column
Next
If CheckIfCanMove(CurrentBlock) Then
.CurrentRotateState = .CurrentRotateState + 1
If .CurrentRotateState = 5 Then
.CurrentRotateState = 1
End If
Call DrawGameArea(CurrentBlock)
End If
ElseIf r = 22 Then ' ?ò???ù?è?ó?ì
GameSpeed = 0.01
End If
Cells(21, 21).Activate
End With
End If
Application.EnableEvents = True
End Sub
Private Sub CheckFullRow()
Dim Row As Integer, Column As Integer
Dim TempColumn As Integer, TempRow As Integer, TempColor As Double
Dim IsFullRow As Boolean
Dim dd As Boolean
cc = 0
Row = Range("GameArea").Rows.Count
Column = Range("GameArea").Columns.Count
Application.ScreenUpdating = False
Do While Row > 3
IsFullRow = True
For TempColumn = 1 To Column
dd = IIf(Range("ccc").Cells(Row, TempColumn).Value <> 0, True, False)
If dd = False Then
IsFullRow = False
End If
Next
If IsFullRow Then
cc = cc + 1
Call AddScore
With Range("GameArea")
For TempRow = Row To 2 Step -1
.Rows(TempRow).Clear
Range("ccc").Rows(TempRow).Clear
Range("cccc").Rows(TempRow).Clear
For TempColumn = 1 To Column
Range("ccc")(TempRow, TempColumn).Cells.Value = Range("ccc").Cells(TempRow - 1, TempColumn).Value
Range("cccc")(TempRow, TempColumn).Cells.Value = Range("cccc").Cells(TempRow - 1, TempColumn).Value
If Range("ccc")(TempRow, TempColumn).Cells.Value <> 0 Then
.Cells(TempRow, TempColumn).Interior.Pattern = xlPatternRectangularGradient
.Cells(TempRow, TempColumn).Interior.Gradient.RectangleLeft = 0.4
.Cells(TempRow, TempColumn).Interior.Gradient.RectangleRight = 0.6
.Cells(TempRow, TempColumn).Interior.Gradient.RectangleTop = 0.4
.Cells(TempRow, TempColumn).Interior.Gradient.RectangleBottom = 0.6
.Cells(TempRow, TempColumn).Interior.Gradient.ColorStops.Clear
.Cells(TempRow, TempColumn).Interior.Gradient.ColorStops.Add(0).Color = Range("cccc")(TempRow, TempColumn).Cells.Value
.Cells(TempRow, TempColumn).Interior.Gradient.ColorStops.Add(1).Color = Range("ccc")(TempRow, TempColumn).Cells.Value
.Cells(TempRow, TempColumn).Borders(xlEdgeBottom).LineStyle = xlContinuous
.Cells(TempRow, TempColumn).Borders(xlEdgeBottom).Weight = xlThin
End If
Next
Next
End With
Else
Row = Row - 1
End If
Loop
Application.ScreenUpdating = True
End Sub
Sub StopGame_Click()
Call StopGame
End Sub
Sub StartGame_Click()
Call StartGame
End Sub