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

おさらい

前回、

vba-belle-equipe.hatenablog.com

とりあえず左右に動かすところまでいきました。

現状報告

上方向のキーで上の段に進んでいき、

2段目まで行った時に到達おめでたうメッセージ表示。

下方向のキーで中断メッセージ表示。

というところまでいきました。

あと、ゲーム表示部分の色を変えたり、変数名を変えたり、コメントをつけたりと細かいところが色々変わっています。

コード

現時点でのコードは

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

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 ContinueFlg As Boolean
Public ColPos As Long  '動いているものの横位置
Public RowPos As Long  '動いているものの縦位置
Public Migi As Boolean '方向（true:右方向）
Public Kaisu As Long

'ゲームメイン処理
Sub gameRoop()
  Dim i As Long
  Dim StartTime As Long
  Dim RoopTime As Long
  ContinueFlg = True
  RoopTime = 500
  ColPos = MINCOL - 1
  RowPos = MAXROW
  Migi = True
  Call allClear
  Do While ContinueFlg = True
    StartTime = GetTickCount
    Kaisu = 0
    Call doGame
    Do While GetTickCount - StartTime < RoopTime
      If Kaisu = 0 And GetAsyncKeyState(VK_UP) And &H8000 Then
        Call doStop
      ElseIf GetAsyncKeyState(VK_DOWN) And &H8000 Then
        MsgBox "中断されました"
        ContinueFlg = False
      End If
    Loop
  Loop
End Sub

'値の初期化（クリア）
Sub allClear()
  Range("R1:R2").ClearContents
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
  RowPos = RowPos - 1
  Range("P2") = RowPos
  ColPos = MINCOL - 1
  Migi = True
  If RowPos < MINROW Then
    MsgBox "上まで来ました"
    ContinueFlg = False
  End If
End Sub

'左右に動かす
Sub cellMove()
  Range("B2:J18").Interior.ColorIndex = 1
  If MINCOL <= ColPos And ColPos <= MAXCOL Then
    Cells(RowPos, ColPos).Interior.ColorIndex = 6
  End If
End Sub

こんな感じです。

Const結構増えたなあ。

課題

基本的にメインの操作はボタン1つだけなので、スペースキーにしたい。*1

あと、セルが選択されている感を消したいところです。

参考文献

キーが押された状態であるかの判断等、

home.att.ne.jp

こちらを参考にさせていただきました。

*1:スペースキー本来の「セルに空白を入れる」という動きを抑えるのが難しそうなので、とりあえず方向キーにしています