ExcelVBA；GAME Fall Down Panic 〜 落下物を避けて生き延びよ！
懐かしのレトロゲーム風の単純サバイバルGAMEのコード・プログラムです。
【コード・プログラム】
' ExcelVBA 落下物を避けて生き延びよ！
Dim posX As Integer
Dim posY As Integer
Dim charSymbol As String
Dim gameOver As Boolean
Dim fallObjects As Collection
Dim gameRange As Range
Dim nextTick As Double
Sub StartGame()
Dim ws As Worksheet
Set ws = ActiveSheet
ws.Cells.Clear
Set gameRange = ws.Range("B2:K11") ' 10列×10行
With gameRange
.Interior.Color = vbBlack
.Font.Color = vbGreen
.Font.Bold = True
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
posX = 5: posY = 10 ' 中央下
charSymbol = "大"
gameOver = False
Set fallObjects = New Collection
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{RIGHT}", "MoveRight"
DrawScene
ScheduleNextTick
End Sub
Sub ScheduleNextTick()
If Not gameOver Then
nextTick = Now + TimeSerial(0, 0, 0.6)
Application.OnTime nextTick, "GameTick"
End If
End Sub
Sub GameTick()
MoveObjectsDown
If fallObjects.Count < 3 Then SpawnObject
CheckCollision
DrawScene
ScheduleNextTick
End Sub
Sub DrawScene()
gameRange.ClearContents
' 落下物描画
Dim i As Integer
For i = 1 To fallObjects.Count
Dim coords As Variant: coords = fallObjects(i)
If IsArray(coords) And UBound(coords) = 1 Then
Dim fx As Integer: fx = coords(0)
Dim fy As Integer: fy = coords(1)
If fy >= 1 And fy <= gameRange.Rows.Count Then
gameRange.Cells(fy, fx).Value = "■"
End If
End If
Next
' キャラ描画
gameRange.Cells(posY, posX).Value = charSymbol
End Sub
Sub MoveLeft()
If posX > 1 Then
posX = posX - 1
ToggleCharSymbol
DrawScene
End If
End Sub
Sub MoveRight()
If posX < gameRange.Columns.Count Then
posX = posX + 1
ToggleCharSymbol
DrawScene
End If
End Sub
Sub ToggleCharSymbol()
If charSymbol = "大" Then
charSymbol = "火"
Else
charSymbol = "大"
End If
End Sub
Sub SpawnObject()
Dim col As Integer: col = Int(Rnd() * gameRange.Columns.Count) + 1
fallObjects.Add Array(col, 1) ' X, Y
End Sub
Sub MoveObjectsDown()
Dim newFall As New Collection
Dim i As Integer
For i = 1 To fallObjects.Count
Dim coords As Variant: coords = fallObjects(i)
If IsArray(coords) And UBound(coords) = 1 Then
Dim fx As Integer: fx = coords(0)
Dim fy As Integer: fy = coords(1)
If fy < gameRange.Rows.Count Then
newFall.Add Array(fx, fy + 1)
End If
End If
Next
Set fallObjects = newFall
End Sub
Sub CheckCollision()
Dim i As Integer
For i = 1 To fallObjects.Count
Dim coords As Variant: coords = fallObjects(i)
If IsArray(coords) And UBound(coords) = 1 Then
If coords(0) = posX And coords(1) = posY Then
gameOver = True
MsgBox "GAME OVER", vbCritical
Application.OnKey "{LEFT}"
Application.OnKey "{RIGHT}"
Exit For
End If
End If
Next
End Sub
【実際に動作しているところの動画】
https://youtube.com/shorts/-k7jbHN8j-c?si=WutFfXk1BDGtupG4
