Excelでブロック積みゲームを作る その5
現状報告
こんな感じです。
ちょっとわかりづらいですが、
- ゲーム終了後、中断か続行かをキー入力で受けつけるように
- メッセージ表示エリアを作成
あたりを実装しました。
コード
現時点でのコードは
'///シートモジュール/// 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」というフォントを使わせていただきました。
なんとなく雰囲気が出るので、いい感じです。