不朽の名作レトロゲーム「パックマン」風GAME「paCellman」
令和の時代に、ExcelVBAで再現を試みようとした、コード・プログラムです。
'paCellman
Dim maze(1 To 15, 1 To 15) As String
Dim px As Integer, py As Integer
Dim gx As Integer, gy As Integer
Dim score As Long, lives As Integer
Dim frightenedMode As Boolean
Dim frightEndTime As Double
Dim gameOn As Boolean
Dim goalX As Integer, goalY As Integer
Sub StartPacmanGame()
Dim i As Integer, j As Integer
px = 8: py = 8
gx = 8: gy = 7
goalX = 15: goalY = 14 ' 脱出口の座標
score = 0
lives = 3
frightenedMode = False
gameOn = True
Dim layout As Variant
layout = Array( _
"WWWWWWWWWWWWWWW", _
"W・・W・★・・・・・・・・W", _
"W・WWW・W・WWW・W・W", _
"W・W・・・W・・・・・W・W", _
"W・W・WWW・WWW・W・W", _
"W・・・W・・・W・・・・・W", _
"WWW・W・WWW・W・WWW", _
"W・・・・・・C・・・・・・W", _
"W・W・WWW・W・WWW・W", _
"W・W・・・W・・・・・・・W", _
"W・WWW・W・WWW・・WW", _
"W・・W・・・★・・・・W・W", _
"W・WWW・WWW・・WW・W", _
"W・・・・・・・・・G・・・W", _
"WWWWWWWWWWWWW W") ' 右下の14列目だけ空白（脱出口）
For i = 1 To 15
For j = 1 To 15
maze(i, j) = Mid(layout(i - 1) & Space(15), j, 1)
Next j
Next i
DrawMaze
ShowStatus
Application.OnKey "{UP}", "MoveUp"
Application.OnKey "{DOWN}", "MoveDown"
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{RIGHT}", "MoveRight"
Application.OnTime Now + TimeValue("00:00:01"), "GhostMove"
End Sub
Sub DrawMaze()
Dim i As Integer, j As Integer
Cells.Clear
For i = 1 To 15
For j = 1 To 15
With Cells(i, j)
.Value = maze(i, j)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
Select Case maze(i, j)
Case "W": .Interior.Color = RGB(0, 0, 255)
Case "・": .Interior.Color = RGB(255, 255, 255)
Case "★": .Interior.Color = RGB(255, 215, 0)
Case "C": .Interior.Color = RGB(255, 255, 0)
Case "G"
If frightenedMode Then
.Interior.Color = RGB(0, 255, 255)
Else
.Interior.Color = RGB(255, 0, 0)
End If
Case Else: .Interior.ColorIndex = 0
End Select
End With
Next j
Next i
End Sub
Sub ShowStatus()
With Range("R1")
.Value = "スコア: " & score
.Font.Bold = True
End With
With Range("R2")
.Value = "残機: " & lives
.Font.Bold = True
End With
End Sub
Sub MovePacman(dx As Integer, dy As Integer)
If Not gameOn Then Exit Sub
Dim nx As Integer, ny As Integer
nx = px + dx: ny = py + dy
If maze(nx, ny) <> "W" Then
' ゴーストとの衝突判定
If nx = gx And ny = gy Then
If frightenedMode Then
score = score + 200
gx = 2: gy = 2
Else
MsgBox "ゲームオーバー！"
gameOn = False
Exit Sub
End If
End If
' 脱出口到達でクリア判定
If nx = goalX And ny = goalY Then
maze(px, py) = " "
px = nx: py = ny
maze(px, py) = "C"
DrawMaze
MsgBox "クリア！"
gameOn = False
Exit Sub
End If
' クッキー・パワークッキー処理
If maze(nx, ny) = "・" Then score = score + 10
If maze(nx, ny) = "★" Then
frightenedMode = True
frightEndTime = Timer + 7
End If
maze(px, py) = " "
px = nx: py = ny
maze(px, py) = "C"
DrawMaze
ShowStatus
End If
End Sub
Sub MoveUp(): MovePacman -1, 0
End Sub
Sub MoveDown(): MovePacman 1, 0
End Sub
Sub MoveLeft(): MovePacman 0, -1
End Sub
Sub MoveRight(): MovePacman 0, 1
End Sub
Sub GhostMove()
If Not gameOn Then Exit Sub
Dim dirs As Variant, i As Integer
dirs = Array(Array(-1, 0), Array(1, 0), Array(0, -1), Array(0, 1))
For i = 0 To 3
Dim dx As Integer, dy As Integer
dx = dirs(i)(0): dy = dirs(i)(1)
If maze(gx + dx, gy + dy) <> "W" And maze(gx + dx, gy + dy) <> "C" Then
maze(gx, gy) = " "
gx = gx + dx: gy = gy + dy
maze(gx, gy) = "G"
Exit For
End If
Next i
If frightenedMode And Timer > frightEndTime Then frightenedMode = False
DrawMaze
ShowStatus
Application.OnTime Now + TimeValue("00:00:01"), "GhostMove"
End Sub
【実際に動作しているところの動画のURL】
https://youtube.com/shorts/uVYDXpd7QMg?si=gsxRe6kjy4zV8yMo
