読者です 読者をやめる 読者になる 読者になる

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

Excelでアクションゲーム

おさらい

前回、

vba-belle-equipe.hatenablog.com

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

現状報告

f:id:vba-belle-equipe:20160414180422g:plain

こんな感じです。*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にする時に設定を間違えたのか、実際よりかなり速いですが、面白いのでそのままにしておきます