テトリス風GAME for Excel コード・プログラム
念願のテトリス（風）GAMEを、Excelで再現することが出来ました（TT）
縦軸（列幅）は、144ピクセルが良いかと思います。
＜(_ _)＞
【コード・プログラム】
Option Explicit
Dim blockShapes As Variant, blockColors As Variant
Dim currentBlock As Variant, currentColor As Long
Dim blockTop As Long, blockLeft As Long
Dim fallTimer As Double, gameOverFlag As Boolean
Dim fixedCells() As String, fixedColors() As Long
Const ROWS_COUNT As Long = 11
Const COLS_COUNT As Long = 10
Const GRID_LEFT As Long = 2 ' B列から描画
Const GRID_TOP As Long = 2 ' 2行目から描画
Sub StartGame()
Cells.Clear
Dim r As Long, c As Long
For r = GRID_TOP To GRID_TOP + ROWS_COUNT - 1
For c = GRID_LEFT To GRID_LEFT + COLS_COUNT - 1
With Cells(r, c)
.Font.Name = "MS Gothic"
.Font.Size = 11
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
If c >= 4 Then .Borders.LineStyle = xlContinuous ' D列から枠線
End With
Next
Next
blockShapes = Array( _
Array("■■■"), _
Array(" ■", " ■", " ■"), _
Array(" ■", " ■■", " ■"), _
Array(" ■", " ■■", " ■"), _
Array(" ■■", " ■■"), _
Array(" ■■■", " ■"), _
Array(" ■■■", " ■"), _
Array(" ■", " ■■■"), _
Array(" ■", " ■■■"), _
Array(" ■", " ■■■") _
)
blockColors = Array( _
RGB(255, 0, 0), RGB(0, 128, 255), RGB(0, 200, 0), RGB(255, 128, 0), _
RGB(128, 0, 255), RGB(255, 0, 128), RGB(0, 255, 255), RGB(255, 255, 0), _
RGB(128, 128, 128), RGB(0, 0, 255) _
)
ReDim fixedCells(1 To ROWS_COUNT, 1 To COLS_COUNT)
ReDim fixedColors(1 To ROWS_COUNT, 1 To COLS_COUNT)
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{RIGHT}", "MoveRight"
gameOverFlag = False
blockTop = 1
blockLeft = 1
SpawnBlock
fallTimer = Timer
Application.OnTime Now + TimeValue("00:00:01"), "GameLoop"
End Sub
Sub SpawnBlock()
Dim i As Long
i = Int(Rnd() * UBound(blockShapes) + 1)
currentBlock = blockShapes(i)
currentColor = blockColors(i)
If CheckCollision(blockTop, blockLeft) Then
MsgBox "ゲームオーバー！", vbExclamation
gameOverFlag = True
Exit Sub
End If
DrawBlock
End Sub
Sub DrawBlock()
Dim r As Long, c As Long
For r = 1 To ROWS_COUNT
For c = 1 To COLS_COUNT
With Cells(GRID_TOP + r - 1, GRID_LEFT + c - 1)
.Value = fixedCells(r, c)
.Interior.Color = IIf(fixedColors(r, c) = 0, xlNone, fixedColors(r, c))
End With
Next
Next
Dim i As Long, j As Long, line As String
For i = 0 To UBound(currentBlock)
line = currentBlock(i)
For j = 1 To Len(line)
If Mid(line, j, 1) <> " " Then
Dim rPos As Long: rPos = blockTop + i
Dim cPos As Long: cPos = blockLeft + j - 1
If rPos >= 1 And rPos <= ROWS_COUNT And cPos >= 1 And cPos <= COLS_COUNT Then
With Cells(GRID_TOP + rPos - 1, GRID_LEFT + cPos - 1)
.Value = Mid(line, j, 1)
.Interior.Color = currentColor
End With
End If
End If
Next
Next
End Sub
Sub MoveLeft()
If blockLeft > 1 Then
If Not CheckCollision(blockTop, blockLeft - 1) Then
blockLeft = blockLeft - 1
DrawBlock
End If
End If
End Sub
Sub MoveRight()
If blockLeft < COLS_COUNT - 2 Then
If Not CheckCollision(blockTop, blockLeft + 1) Then
blockLeft = blockLeft + 1
DrawBlock
End If
End If
End Sub
Function CheckCollision(topPos As Long, leftPos As Long) As Boolean
Dim i As Long, j As Long, line As String
For i = 0 To UBound(currentBlock)
line = currentBlock(i)
For j = 1 To Len(line)
If Mid(line, j, 1) <> " " Then
Dim r As Long: r = topPos + i
Dim c As Long: c = leftPos + j - 1
If r > ROWS_COUNT Or c < 1 Or c > COLS_COUNT Then
CheckCollision = True: Exit Function
End If
If fixedCells(r, c) <> "" Then
CheckCollision = True: Exit Function
End If
End If
Next
Next
CheckCollision = False
End Function
Sub GameLoop()
If gameOverFlag Then Exit Sub
If Timer - fallTimer >= 1 Then
If Not CheckCollision(blockTop + 1, blockLeft) Then
blockTop = blockTop + 1
DrawBlock
Else
FixBlock
CheckLineClear
blockTop = 1
blockLeft = 1
SpawnBlock
End If
fallTimer = Timer
End If
Application.OnTime Now + TimeValue("00:00:01"), "GameLoop"
End Sub
Sub FixBlock()
Dim i As Long, j As Long, line As String
For i = 0 To UBound(currentBlock)
line = currentBlock(i)
For j = 1 To Len(line)
If Mid(line, j, 1) <> " " Then
Dim r As Long: r = blockTop + i
Dim c As Long: c = blockLeft + j - 1
If r >= 1 And r <= ROWS_COUNT And c >= 1 And c <= COLS_COUNT Then
fixedCells(r, c) = Mid(line, j, 1)
fixedColors(r, c) = currentColor
End If
End If
Next
Next
End Sub
Sub CheckLineClear()
Dim r As Long, c As Long, count As Long
For r = ROWS_COUNT To 1 Step -1
count = 0
For c = 1 To COLS_COUNT
If fixedCells(r, c) <> "" Then count = count + 1
Next
If count >= 8 Then ClearLine r
Next
End Sub
Sub ClearLine(rowIndex As Long)
Dim r As Long, c As Long
For r = rowIndex To 2 Step -1
For c = 1 To COLS_COUNT
fixedCells(r, c) = fixedCells(r - 1, c)
fixedColors(r, c) = fixedColors(r - 1, c)
Next
Next
For c = 1 To COLS_COUNT
fixedCells(1, c) = ""
fixedColors(1, c) = 0
Next
End Sub
【実際に動作しているところの動画】
https://youtube.com/shorts/11c_sRZCrRI?si=UQPmHQTXa9_oESFd
