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

おさらい

前回、

vba-belle-equipe.hatenablog.com

上キーでブロックが上昇、下キーで中断するところまでいきました。

現状報告

こんな感じです。*1

• 上昇した時のスタート位置、向きをランダムに
• 段が移っても止めた位置を残しておくように
• 止めたとき、下の段に重なっているか判定
• 重なっていなかったら終了

あたりを実装し、わりとゲームっぽくなってきました。

コード

現時点でのコードは

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

Private Sub CommandButton1_Click()
  Application.EnableEvents = False
  Range("L1").Select
  Call gameRoop
  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 = 2
Public Const MAXCOL As Long = 10
Public Const MINROW As Long = 2
Public Const MAXROW As Long = 18
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  '背景色（colorindex指定）
Public BlockColor As Long '動くブロックの色（colorindex指定）
Public ErrColor As Long '失敗時の色（colorindex指定）

'ゲームメイン処理
Sub gameRoop()
  Dim i As Long
  Dim StartTime As Long
  Dim RoopTime As Long
  FlgContinue = True
  RoopTime = 150
  ColPos = MINCOL - 1
  RowPos = MAXROW
  Migi = True
  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
        MsgBox "中断されました"
        FlgContinue = False
      End If
    Loop
  Loop
End Sub

'セル色、値の初期化や各種設定など、実行前準備
Sub junbi()
  BackColor = 1
  BlockColor = 6
  ErrColor = 3
  Range("R1:R3").ClearContents
  Range(Cells(MINROW, MINCOL), Cells(MAXROW, MAXCOL)) _
    .Interior.ColorIndex = BackColor
End Sub

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

'キーを押した時の処理
Sub doStop()
  Kaisu = Kaisu + 1
  If RowPos <> MAXROW And kasanari = False Then
    Cells(RowPos, ColPos).Interior.ColorIndex = ErrColor
    MsgBox "残念"
    FlgContinue = False
  End If
  RowPos = RowPos - 1
  Range("P2") = RowPos
  ColPos = Int(Rnd * (MAXCOL - MINCOL + 1)) + 2   '出現横位置
  Migi = Int(Rnd * 2)
'  Debug.Print ColPos & "_" & Migi
  If RowPos < MINROW Then
    MsgBox "おめでたう"
    FlgContinue = False
  End If
End Sub

'重なり判定
Function kasanari() As Boolean
  Dim cl As Long
  cl = Cells(RowPos + 1, ColPos).Interior.ColorIndex
  Select Case cl
    Case BlockColor
      kasanari = True    '成功
    Case False
      kasanari = False   '失敗
  End Select
End Function

'左右に動かす
Sub cellMove()
  Range(Cells(RowPos, MINCOL), Cells(RowPos, MAXCOL)) _
        .Interior.ColorIndex = BackColor
  If MINCOL <= ColPos And ColPos <= MAXCOL Then
    Cells(RowPos, ColPos).Interior.ColorIndex = BlockColor
  End If
End Sub

こんな感じです。

プロシージャとか変数とか、日本語にしたほうがいいか迷います。

課題

上キーを押した時に二段上に行ってしまうことがあるため、「Sleep (500) 」を入れてとりあえずしのいでいますが、何かもっといい方法があるのではという気も...

使用ソフト・サービス等

キャプチャに「Screenpresso」

アニメーションgif作成に「Giraf2」を使わせていただきました。

作者の方々、ありがとうございます。

*1:アニメーションgifにする時に設定を間違えたのか、実際よりかなり速いですが、面白いのでそのままにしておきます