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

おさらい
現状報告
コード
課題

おさらい

前回、

vba-belle-equipe.hatenablog.com

左右に動く幅１のブロックを重ねて行き、上まで行ったらクリア、途中で重ならなかったらアウト、というところまで行きました。

現状報告

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

こんな感じです。

ブロックの幅を段ごとに変化させるように
重なり判定を幅の数だけ行う（1ブロックでも重なって入れば次の段に）
設定したブロックの幅よりも、下の段の重なりが少なかった場合は、重なった数の幅でブロックが流れてくる
左右に動くスピードも段ごとに設定

あたりを実装しました。

あとは実際に動かして、色々とエラーになったので、色々と修正しました。

コード

現時点でのコードは

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

Private Sub CommandButton1_Click()
  Application.EnableEvents = False
  Range("A1").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 = 3
Public Const MAXCOL As Long = 11
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指定）
Public Haba As Long  '動くブロックの幅
Public BlockRange As Range  '動くブロックの範囲
Public RoopTime As Long  'ブロックの速さ

'ゲームメイン処理
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
        MsgBox "中断されました"
        FlgContinue = False
      End If
    Loop
  Loop
End Sub

'セル色、値の初期化や各種設定など、実行前準備
Sub junbi()
  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
    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