【ExcelVBA】気分だけRoadRunner風レトロゲーム；コード・プログラム
Option Explicit
Dim px As Integer, py As Integer
Dim asciiChar(1 To 5) As String
Dim ws As Worksheet
Dim obstacleX As Integer, obstacleH As Integer
Dim gameRunning As Boolean
Dim isJumping As Boolean
Dim score As Integer
Sub StartGame()
Set ws = ThisWorkbook.Sheets(1)
ws.Cells.Clear
px = 10: py = 11 ' キャラの足元がRow 16に来る
InitFrontChar
gameRunning = True
isJumping = False
obstacleX = 0
score = 0
DrawChar
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{RIGHT}", "MoveRight"
Application.OnKey "{UP}", "Jump"
GameLoop
End Sub
Sub InitFrontChar()
asciiChar(1) = " ■ "
asciiChar(2) = " ■■■ "
asciiChar(3) = " ■ ■ ■"
asciiChar(4) = " ■ ■ "
asciiChar(5) = " ■ ■ "
End Sub
Sub InitJumpChar()
asciiChar(1) = " ■ ■ ■"
asciiChar(2) = " ■■■ "
asciiChar(3) = " ■ "
asciiChar(4) = " ■ ■ "
asciiChar(5) = " ■ ■ "
End Sub
Sub InitLeftChar()
asciiChar(1) = " ■ "
asciiChar(2) = " ■■■ "
asciiChar(3) = " ■ ■ ■"
asciiChar(4) = " ■ ■ "
asciiChar(5) = " ■ ■"
End Sub
Sub InitRightChar()
asciiChar(1) = " ■ "
asciiChar(2) = " ■■■ "
asciiChar(3) = " ■ ■ ■"
asciiChar(4) = " ■ ■ "
asciiChar(5) = " ■ ■ "
End Sub
Sub DrawChar()
Dim i As Integer
ws.Cells.Clear
For i = 1 To 5
ws.Cells(py + i, px).Value = asciiChar(i)
Next i
DrawObstacle
DrawGround
ws.Cells(1, 1).Value = "Score: " & score
ws.Cells.Font.Name = "ＭＳ ゴシック"
ws.Cells.Font.Size = 11
End Sub
Sub DrawGround()
Dim c As Integer
For c = 1 To 30
ws.Cells(17, c).Value = "＝" ' 地面をRow 17に変更
Next c
End Sub
Sub MoveLeft()
If px > 1 Then px = px - 1
InitLeftChar
DrawChar
End Sub
Sub MoveRight()
If px < 25 Then px = px + 1
InitRightChar
DrawChar
End Sub
Sub Jump()
If Not isJumping Then
py = py - 6 ' 高くジャンプ
isJumping = True
InitJumpChar
DrawChar
Application.OnTime Now + TimeValue("00:00:02"), "Land"
End If
End Sub
Sub Land()
py = py + 6
isJumping = False
InitFrontChar
DrawChar
End Sub
Sub GameLoop()
If Not gameRunning Then Exit Sub
ScrollObstacle
DrawChar
CheckCollision
Application.OnTime Now + TimeValue("00:00:01"), "GameLoop"
End Sub
Sub DrawObstacle()
If obstacleX > 0 Then
Dim i As Integer
For i = 0 To obstacleH - 1
ws.Cells(16 - i, obstacleX).Value = "■" ' 障害物の足元はRow 16
Next i
End If
End Sub
Sub ScrollObstacle()
If obstacleX = 0 Then
obstacleX = 30
obstacleH = IIf(Rnd < 0.5, 1, 2) ' 1段 or 2段
Else
obstacleX = obstacleX - 1
If obstacleX = px - 1 Then
score = score + 1
End If
If obstacleX = 0 Then
obstacleX = 30
obstacleH = IIf(Rnd < 0.5, 1, 2)
End If
End If
End Sub
Sub CheckCollision()
If obstacleX = px Then
Dim i As Integer, oy As Integer
For i = 1 To 5
For oy = 0 To obstacleH - 1
If py + i = 16 - oy Then
GameOver
Exit Sub
End If
Next oy
Next i
End If
End Sub
Sub GameOver()
gameRunning = False
MsgBox "Game Over! Score: " & score
Application.OnKey "{LEFT}"
Application.OnKey "{RIGHT}"
Application.OnKey "{UP}"
End Sub
【実際に動作しているところの動画】
https://youtube.com/shorts/0s8Big44iJI?si=33X8ebittnE10L0o
