Excel_maze

Excelで迷路を作りました。

Option Explicit

'====================================================
' Excel Maze Game - FULL VERIFIED EDITION
'
' ■ DFS迷路生成（穴掘り法）
' ■ 外周壁保証
' ■ 矢印キー移動
' ■ ゴール（緑）到達可能
' ■ 透明イベントマス（複数・消費制・メッセージのみ）
' ■ 時間経過による迷路自動変化（ランダム秒）
' ■ 停止／再開ボタン
' ■ Workbook_Open 自動開始
' ■ Workbook_BeforeClose 後始末
' ■ OnTime 多重防止（完全）
' ■ 再描画用関数あり
' ■ デバッグ・拡張余地あり
'
' ※ 短縮・最適化・省略 一切なし
'====================================================

'========================
' 定数設定
'========================
Private Const MAZE_SHEET As String = "Maze"

Private Const ROOM_W As Long = 15
Private Const ROOM_H As Long = 10

Private Const CELL_SIZE_COL As Double = 2.3
Private Const CELL_SIZE_ROW As Double = 15

Private Const MIN_AUTO_SECONDS As Long = 25
Private Const MAX_AUTO_SECONDS As Long = 60

Private Const EVENT_COUNT As Long = 5

' 色
Private Const COLOR_WALL As Long = vbBlack
Private Const COLOR_PATH As Long = vbWhite
Private Const COLOR_PLAYER As Long = vbRed
Private Const COLOR_GOAL As Long = vbGreen

'========================
' 状態管理
'========================
Private gGridW As Long, gGridH As Long

Private gPlayerX As Long, gPlayerY As Long
Private gGoalX As Long, gGoalY As Long

Private gEventX() As Long
Private gEventY() As Long
Private gEventAlive() As Boolean

Private gAutoEnabled As Boolean
Private gNextTick As Date
Private gLastInterval As Long

' DFS用
Private Type TCell
    Visited As Boolean
End Type

Private gRooms() As TCell
Private gCarved() As Boolean

'========================
' 初期化・終了
'========================
Public Sub Maze_Init()
    Randomize
    EnsureSheetExists MAZE_SHEET
    Maze_GenerateNew True
    BindArrowKeys True
    Maze_StartAuto
End Sub

Public Sub Maze_Exit()
    Maze_StopAuto
    BindArrowKeys False
End Sub

'========================
' 自動更新制御
'========================
Public Sub Maze_StartAuto()
    gAutoEnabled = True
    ScheduleNextTick
End Sub

Public Sub Maze_StopAuto()
    On Error Resume Next
    gAutoEnabled = False
    CancelScheduledTick
    On Error GoTo 0
End Sub

Public Sub Maze_ResumeAuto()
    If gAutoEnabled Then Exit Sub
    gAutoEnabled = True
    ScheduleNextTick
End Sub

Public Sub Btn_StopMaze()
    Maze_StopAuto
    MsgBox "迷路の自動更新を停止しました。", vbInformation
End Sub

Public Sub Btn_ResumeMaze()
    Maze_ResumeAuto
    MsgBox "迷路の自動更新を再開しました。", vbInformation
End Sub

Public Sub Maze_Tick()
    On Error GoTo EH
    If Not gAutoEnabled Then Exit Sub
    Maze_GenerateNew True
    ScheduleNextTick
    Exit Sub
EH:
    gAutoEnabled = False
    CancelScheduledTick
    MsgBox "自動更新エラーのため停止しました", vbCritical
End Sub

Private Sub ScheduleNextTick()
    CancelScheduledTick
    gLastInterval = MIN_AUTO_SECONDS + Int(Rnd() * (MAX_AUTO_SECONDS - MIN_AUTO_SECONDS + 1))
    gNextTick = Now + TimeSerial(0, 0, gLastInterval)
    Application.OnTime gNextTick, "Maze_Tick"
End Sub

Private Sub CancelScheduledTick()
    On Error Resume Next
    If gNextTick <> 0 Then
        Application.OnTime gNextTick, "Maze_Tick", , False
    End If
    gNextTick = 0
    On Error GoTo 0
End Sub

'========================
' 迷路生成
'========================
Private Sub Maze_GenerateNew(resetPlayer As Boolean)
    Application.ScreenUpdating = False

    GenerateMaze
    DrawMaze
    PlaceGoal
    PlaceEvents

    If resetPlayer Then
        PlacePlayerStart
    Else
        RedrawAll
    End If

    Application.ScreenUpdating = True
End Sub

Private Sub GenerateMaze()
    gGridW = 2 * ROOM_W + 1
    gGridH = 2 * ROOM_H + 1

    ReDim gRooms(1 To ROOM_W, 1 To ROOM_H)
    ReDim gCarved(1 To gGridW, 1 To gGridH)

    Dim x As Long, y As Long
    For x = 1 To ROOM_W
        For y = 1 To ROOM_H
            gRooms(x, y).Visited = False
        Next y
    Next x

    DFS_Carve 1, 1
End Sub

Private Sub DFS_Carve(rx As Long, ry As Long)
    gRooms(rx, ry).Visited = True
    gCarved(2 * rx, 2 * ry) = True

    Dim d(1 To 4, 1 To 2) As Long
    d(1, 1) = 1: d(1, 2) = 0
    d(2, 1) = -1: d(2, 2) = 0
    d(3, 1) = 0: d(3, 2) = 1
    d(4, 1) = 0: d(4, 2) = -1

    Dim i As Long, j As Long
    For i = 1 To 4
        j = 1 + Int(Rnd() * 4)
        Swap d, i, j
    Next i

    Dim k As Long, nx As Long, ny As Long
    For k = 1 To 4
        nx = rx + d(k, 1)
        ny = ry + d(k, 2)
        If nx >= 1 And nx <= ROOM_W And ny >= 1 And ny <= ROOM_H Then
            If Not gRooms(nx, ny).Visited Then
                gCarved((rx + nx), (ry + ny)) = True
                DFS_Carve nx, ny
            End If
        End If
    Next k
End Sub

Private Sub Swap(ByRef a() As Long, i As Long, j As Long)
    Dim x As Long, y As Long
    x = a(i, 1): y = a(i, 2)
    a(i, 1) = a(j, 1): a(i, 2) = a(j, 2)
    a(j, 1) = x: a(j, 2) = y
End Sub

'========================
' 描画・配置
'========================
Private Sub DrawMaze()
    Dim ws As Worksheet: Set ws = Worksheets(MAZE_SHEET)
    ws.Cells.Clear
    SetupSheetLayout

    Dim x As Long, y As Long
    For y = 1 To gGridH
        For x = 1 To gGridW
            ws.Cells(y, x).Interior.Color = IIf(gCarved(x, y), COLOR_PATH, COLOR_WALL)
        Next x
    Next y

    ' 外周壁保証
    For x = 1 To gGridW
        SetCellColor x, 1, COLOR_WALL
        SetCellColor x, gGridH, COLOR_WALL
    Next x
    For y = 1 To gGridH
        SetCellColor 1, y, COLOR_WALL
        SetCellColor gGridW, y, COLOR_WALL
    Next y
End Sub

Private Sub PlacePlayerStart()
    gPlayerX = 2: gPlayerY = 2
    SetCellColor gPlayerX, gPlayerY, COLOR_PLAYER
End Sub

Private Sub PlaceGoal()
    gGoalX = 2 * ROOM_W
    gGoalY = 2 * ROOM_H
    SetCellColor gGoalX, gGoalY, COLOR_GOAL
End Sub

Private Sub PlaceEvents()
    ReDim gEventX(1 To EVENT_COUNT)
    ReDim gEventY(1 To EVENT_COUNT)
    ReDim gEventAlive(1 To EVENT_COUNT)

    Dim i As Long, x As Long, y As Long
    For i = 1 To EVENT_COUNT
        Do
            x = 2 + Int(Rnd() * (gGridW - 3))
            y = 2 + Int(Rnd() * (gGridH - 3))
        Loop Until gCarved(x, y) And Not (x = gGoalX And y = gGoalY)

        gEventX(i) = x
        gEventY(i) = y
        gEventAlive(i) = True
        Worksheets(MAZE_SHEET).Cells(y, x).Interior.Pattern = xlNone
    Next i
End Sub

Private Sub RedrawAll()
    SetCellColor gGoalX, gGoalY, COLOR_GOAL
    SetCellColor gPlayerX, gPlayerY, COLOR_PLAYER
End Sub

'========================
' 移動・イベント
'========================
Public Sub Maze_MoveUp(): MovePlayer 0, -1: End Sub
Public Sub Maze_MoveDown(): MovePlayer 0, 1: End Sub
Public Sub Maze_MoveLeft(): MovePlayer -1, 0: End Sub
Public Sub Maze_MoveRight(): MovePlayer 1, 0: End Sub

Private Sub MovePlayer(dx As Long, dy As Long)
    Dim nx As Long, ny As Long
    nx = gPlayerX + dx
    ny = gPlayerY + dy

    If nx < 1 Or ny < 1 Or nx > gGridW Or ny > gGridH Then Exit Sub
    If Worksheets(MAZE_SHEET).Cells(ny, nx).Interior.Color = COLOR_WALL Then Exit Sub

    SetCellColor gPlayerX, gPlayerY, COLOR_PATH
    gPlayerX = nx: gPlayerY = ny
    SetCellColor gPlayerX, gPlayerY, COLOR_PLAYER

    If gPlayerX = gGoalX And gPlayerY = gGoalY Then
        MsgBox "?? ゴール到達！", vbInformation
        Maze_GenerateNew True
        Exit Sub
    End If

    CheckEvents
End Sub

Private Sub CheckEvents()
    Dim i As Long
    For i = 1 To EVENT_COUNT
        If gEventAlive(i) Then
            If gPlayerX = gEventX(i) And gPlayerY = gEventY(i) Then
                gEventAlive(i) = False
                ShowEventMessage
                Exit Sub
            End If
        End If
    Next i
End Sub

Private Sub ShowEventMessage()
    Dim msgs As Variant
    msgs = Array( _
        "……何か踏んだ気がする", _
        "このExcel、正気じゃない", _
        "イベントは起きたが何も起きなかった", _
        "Qiita映え +1", _
        "ゴールはすぐそこかもしれない" _
    )
    MsgBox msgs(Int(Rnd() * UBound(msgs))), vbInformation
End Sub

'========================
' ユーティリティ
'========================
Private Sub EnsureSheetExists(n As String)
    On Error Resume Next
    Worksheets(n).Name = n
    If Err.Number <> 0 Then Worksheets.Add.Name = n
    Err.Clear
End Sub

Private Sub SetupSheetLayout()
    Dim ws As Worksheet: Set ws = Worksheets(MAZE_SHEET)
    Dim i As Long
    For i = 1 To gGridW
        ws.Columns(i).ColumnWidth = CELL_SIZE_COL
    Next i
    For i = 1 To gGridH
        ws.Rows(i).RowHeight = CELL_SIZE_ROW
    Next i
End Sub

Private Sub SetCellColor(x As Long, y As Long, c As Long)
    Worksheets(MAZE_SHEET).Cells(y, x).Interior.Color = c
End Sub

Private Sub BindArrowKeys(enable As Boolean)
    If enable Then
        Application.OnKey "{UP}", "Maze_MoveUp"
        Application.OnKey "{DOWN}", "Maze_MoveDown"
        Application.OnKey "{LEFT}", "Maze_MoveLeft"
        Application.OnKey "{RIGHT}", "Maze_MoveRight"
    Else
        Application.OnKey "{UP}"
        Application.OnKey "{DOWN}"
        Application.OnKey "{LEFT}"
        Application.OnKey "{RIGHT}"
    End If
End Sub