Excelでブロック積みゲームを作る その6

おさらい

前回、

vba-belle-equipe.hatenablog.com

一度マクロを実行したあと、続行か中断かをキー入力でうけつけるようにしました。

現状報告

こんな感じです。

• 段ごとの設定、各種色設定を「設定」シートからもってくる
• 色の設定をinterior.colorindexから、interior.color指定に変更
• タイトルを表示
• ゲームオーバーを表示

あたりを実装しました。

ちなみに「設定」シートは

こんな感じです。

ドイツ感がある、と思いきや微妙に違いました。

コード

現時点でのコードは

'///シートモジュール///

Private Sub CommandButton1_Click()
  Application.EnableEvents = False
  Range("A1").Select
  Call waitingStart
  Application.EnableEvents = True
End Sub



'///標準モジュール///

Option Explicit

Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Public Const VK_SPACE = &H20 '[Space]
Public Const VK_LEFT = &H25 '[←]
Public Const VK_UP = &H26 '[↑]
Public Const VK_RIGHT = &H27 '[→]
Public Const VK_DOWN = &H28 '[↓]
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetTickCount Lib "kernel32" () As Long 'Windows起動後経過時間取得API
Public Const MINCOL As Long = 3
Public Const MAXCOL As Long = 11
Public Const MINROW As Long = 3
Public Const MAXROW As Long = 19
Public FlgContinue As Boolean
Public ColPos As Long  '動くブロックの横位置
Public RowPos As Long  '動くブロックの縦位置
Public Migi As Boolean '方向（true:右方向）
Public Kaisu As Long
Public BackColor As Long  '背景色
Public BlockColor As Long '動くブロックの色
Public ErrColor As Long '失敗時の色
Public Haba As Long  '動くブロックの幅
Public BlockRange As Range  '動くブロックの範囲
Public RoopTime As Long  'ブロックの速さ
Public RngMsg As Range   'メッセージ表示エリア
Public FlgGameStart   'ゲーム自体のスタートフラグ
Public FlgGameEnd     'ゲーム自体の終了フラグ

'スタート待ち
Sub waitingStart()
  Dim StartTime As Long
  Dim tenmetuTime As Long
  tenmetuTime = 500
  FlgGameStart = False
  FlgGameEnd = False
  Set RngMsg = Range("C2")
  Call displayTitle(True)
  Do
    StartTime = GetTickCount
    If RngMsg.Value = "" Then
      RngMsg.Value = "←　→　キーをおしてください"
    Else
      RngMsg.Value = ""
    End If
    DoEvents
    Do While GetTickCount - StartTime < tenmetuTime
      If &H8000 And _
        GetAsyncKeyState(VK_LEFT) Or _
        GetAsyncKeyState(VK_RIGHT) Then
        FlgGameStart = True
      ElseIf GetAsyncKeyState(VK_DOWN) And &H8000 Then
        Call chudan
      End If
    Loop
  Loop While FlgGameStart = False And FlgGameEnd = False
  If FlgGameStart Then
    Call gameRoop
  End If
  If FlgGameEnd = False Then
    Call waitingStart
  End If
  
End Sub

'中断
Sub chudan()
  Call displayTitle(True)
  RngMsg.Value = "ちゅうだんされました"
  FlgContinue = False
  FlgGameEnd = True
End Sub

'ゲームメイン処理
Sub gameRoop()
  Dim i As Long
  Dim StartTime As Long
  Call junbi
  Do While FlgContinue = True
    StartTime = GetTickCount
    Kaisu = 0
    Call doGame
    Do While GetTickCount - StartTime < RoopTime
      If Kaisu = 0 And GetAsyncKeyState(VK_UP) And &H8000 Then
        Call doStop
        Sleep (500)
      ElseIf GetAsyncKeyState(VK_DOWN) And &H8000 Then
        Call chudan
      End If
    Loop
  Loop
End Sub

'セル色、値の初期化や各種設定など、実行前準備
Sub junbi()
  RngMsg.Value = "↑ とめる　↓ ちゅうだん"
  Call displayTitle(False)
  Range("G11").Value = ""
  FlgContinue = True
  RowPos = MAXROW + 1
  Haba = 0
  Call rowSettings
'  Migi = True
  BackColor = Sheets("設定").Range("B21").Interior.Color
  BlockColor = Sheets("設定").Range("B22").Interior.Color
  ErrColor = Sheets("設定").Range("B23").Interior.Color
  Range("R1:R3").ClearContents
  Range(Cells(MINROW, MINCOL), Cells(MAXROW, MAXCOL)) _
    .Interior.Color = BackColor
End Sub

'次の段での設定
Sub rowSettings()
  Dim kariHaba As Long
  RowPos = RowPos - 1
  RoopTime = Sheets("設定").Cells(RowPos, 3) '速さ
  kariHaba = Sheets("設定").Cells(RowPos, 2) '　幅
  If Haba > kariHaba Or Haba = 0 Then
    Haba = kariHaba
  End If
  Range("P2") = RowPos
  ColPos = Int(Rnd * (MAXCOL - MINCOL + 1)) + 3   '出現横位置
  Select Case ColPos
    Case MINCOL
      Migi = True
    Case MAXCOL
      Migi = False
    Case Else
      Migi = Int(Rnd * 2)
  End Select
End Sub

'時間ごとの処理
Sub doGame()
  Select Case Migi
    Case True
      ColPos = ColPos + 1
    Case False
      ColPos = ColPos - 1
  End Select
  
  Range("P1").Value = ColPos
  Call cellMove
  DoEvents
End Sub

'キーを押した時の処理
Sub doStop()
  Kaisu = Kaisu + 1
  If RowPos <> MAXROW Then
    If kasanari = False Then
     ' MsgBox "残念"
      Call displayGameOver
      FlgContinue = False
      Exit Sub
    End If
  End If
  If RowPos = MINROW Then
    MsgBox "おめでたう"
    FlgContinue = False
  Else
    Call rowSettings  '次の段の設定
  End If
End Sub

'タイトル表示（true: 表示　false: 非表示）
Sub displayTitle(flg As Boolean)
  Select Case flg
    Case True
      Range("G4").Value = "Excel"
      Range("G6").Value = "ブロックつみ"
    Case False
      Range("G4").Value = ""
      Range("G6").Value = ""
  End Select
End Sub

'ゲームオーバー
Sub displayGameOver()
  Dim i As Long
  Dim cnt As Long
  Dim r As Range
  cnt = MAXROW - RowPos
  For i = 0 To cnt
    Sleep (100)
    Set r = Range(Cells(RowPos + i, MINCOL), Cells(RowPos + i, MAXCOL))
    r.Interior.Color = BackColor
  Next
  Range("G11").Value = "GAME OVER"
  Call displayTitle(True)
End Sub

'重なり判定
Function kasanari() As Boolean
  Dim cl As Long
  Dim r As Range
  Dim errRange As Range
  Dim cnt As Long
  cnt = 0
  Set errRange = Nothing
  For Each r In BlockRange
    cl = Cells(RowPos + 1, r.Column).Interior.Color
    Select Case cl
      Case BlockColor   '重なっている
        r.Interior.Color = BlockColor
        cnt = cnt + 1
      Case Else        '重なっていない
        If errRange Is Nothing Then
          Set errRange = r
        Else
          Set errRange = Union(errRange, r)
        End If
    End Select
  Next
  If cnt = 0 Then
    kasanari = False
  Else
    kasanari = True
    Haba = cnt '重なっていた数を次の段の幅に適用
  End If
  If errRange Is Nothing Then
  Else
    Call tenmetu(errRange)
  End If
End Function

'点滅させる（重なっていないブロック）
Sub tenmetu(r As Range)
  Dim i As Long
  For i = 1 To 5
    r.Interior.Color = ErrColor
    Sleep (30)
    r.Interior.Color = BackColor
    Sleep (30)
  Next
End Sub

'左右に動かす
Sub cellMove()
  Dim i As Long
  Dim retu As Long
  Range(Cells(RowPos, MINCOL), Cells(RowPos, MAXCOL)) _
        .Interior.Color = BackColor
  Set BlockRange = Nothing
  For i = 0 To Haba - 1
    retu = ColPos + i
    If MINCOL <= retu And retu <= MAXCOL Then
      If BlockRange Is Nothing Then
        Set BlockRange = Cells(RowPos, retu)
      Else
        Set BlockRange = Union(BlockRange, Cells(RowPos, retu))
      End If
    End If
  Next
  BlockRange.Interior.Color = BlockColor
  If BlockRange.Count = 1 Then
    Select Case ColPos
      Case Is <= MINCOL
        Migi = True
      Case MAXCOL
        Migi = False
      Case Else

    End Select
  End If
End Sub

こんな感じです。

段ごとのセッティングについて記述がダブッたりしていたのをこっそりまとめたりしています。

残っていること

とりあえず、クリアした時にご褒美画像でも表示させたいところです。

それから、これまで先送りにしてきた諸問題に取り組んで、解決したり妥協したりできればいいかなと思います。