may the VBA be with you

Excel VBAとか業務自動化とか

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

おさらい

前回、

vba-belle-equipe.hatenablog.com

段ごとにブロックのスピード、幅数を変える、というところまでできました。

現状報告

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

こんな感じです。

ちょっとわかりづらいですが、

  • ゲーム終了後、中断か続行かをキー入力で受けつけるように
  • メッセージ表示エリアを作成

あたりを実装しました。

コード

現時点でのコードは

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

Private Sub CommandButton1_Click()
  Application.EnableEvents = False
  Range("A1").Select
  Call waitingStart
  Sleep (1000)
  Range("A1").Select
  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  '背景色(colorindex指定)
Public BlockColor As Long '動くブロックの色(colorindex指定)
Public ErrColor As Long '失敗時の色(colorindex指定)
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")
  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()
  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 = "↑ とめる ↓ ちゅうだん"
  FlgContinue = True
  ColPos = MINCOL - 1
  RowPos = MAXROW
  RoopTime = Cells(RowPos, MAXCOL + 2) '速さ
  Haba = Cells(RowPos, MAXCOL + 1)
  Migi = True
  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
  
  Range("P1").Value = ColPos
  Call cellMove
  DoEvents
End Sub

'キーを押した時の処理
Sub doStop()
  Kaisu = Kaisu + 1
  If RowPos <> MAXROW Then
    If kasanari = False Then
      MsgBox "残念"
      FlgContinue = False
      Exit Sub
    End If
  End If
  '次の段での設定
  RowPos = RowPos - 1
  RoopTime = Cells(RowPos, MAXCOL + 2)  '速さ
  If Haba > Cells(RowPos, MAXCOL + 1) Then
    Haba = Cells(RowPos, MAXCOL + 1)
  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
'  Debug.Print ColPos & "_" & Migi
  If RowPos < MINROW Then
    MsgBox "おめでたう"
    FlgContinue = False
  End If
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.ColorIndex
    Select Case cl
      Case BlockColor   '重なっている
        r.Interior.ColorIndex = 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.ColorIndex = ErrColor
    Sleep (30)
    r.Interior.ColorIndex = BackColor
    Sleep (30)
  Next
End Sub

'左右に動かす
Sub cellMove()
  Dim i As Long
  Dim retu As Long
  Range(Cells(RowPos, MINCOL), Cells(RowPos, MAXCOL)) _
        .Interior.ColorIndex = 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.ColorIndex = 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

こんな感じです。

「残念」等、とりあえずmsgboxにしているものは、今後、画面上に表示する方向で。

課題

以前からの課題ですが、セルの選択感と動いてる感(方向キーにより)をなんとかしたいところです。

使用フォント

ドットドットしたゲームなので、「FAMania」というフォントを使わせていただきました。

なんとなく雰囲気が出るので、いい感じです。