may the VBA be with you

Excel VBAとか業務自動化とか

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

Excelでアクションゲーム

おさらい

前回、

vba-belle-equipe.hatenablog.com

ゲームオーバー画面を作りました。

現状報告

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

こんな感じです。

  • クリア（ご褒美）画面
  • キー入力をEnterとSpaceに変更

あたりを実装しました。

長年の懸念であった、セルの選択感アンド動いちゃう感に関して、

  • シートにダミーの画像を置いておいて
  • それをselect

することで、とりあえず解決したような感じがしないでもないです。

余談

解決に至るまでに、

Excelで、Spaceキー(半角の場合)を押してもセルのデータを変更できないようにしたい。〜パソコンの小技・備忘録

こちらや

https://support.microsoft.com/ja-jp/kb/101567

こちらを参考にしてキー入力を制御しようとしたんですが、ご褒美画像貼り付け等がうまくいかず断念。

かなり時間をとられました。


ま、余談ですが。

ご褒美画面

元々はゲーム画面にドット絵で描こうと思ってたんですが、さすがに粗すぎてうまくいかず。

で、別シートにもう少し細かいドットで描き、セル範囲を画像として貼り付ける、という方法に落ち着きました。


「画面パターン」シートに、ご褒美画像を設定しています。

f:id:vba-belle-equipe:20160420181756p:plain

こんな感じです。


コード

現時点でのコードは

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

Private Sub btnStart_Click()
  Application.EnableEvents = False
  ActiveSheet.Shapes("dummy").Select
  Call eraseImages  '念のため画像を消す
  Call waitingStart
  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 '[↓]
Public Const VK_RETURN = &HD '[Enter]
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  '背景色
Public BlockColor As Long '動くブロックの色
Public ErrColor As Long '失敗時の色
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")
  Call displayTitle(True)
  Do
    StartTime = GetTickCount
    If RngMsg.Value = "" Then
      RngMsg.Value = "Space スタート　Enter やめる"
    Else
      RngMsg.Value = ""
    End If
    DoEvents
    Do While GetTickCount - StartTime < tenmetuTime
      If &H8000 And GetAsyncKeyState(VK_SPACE) Then
        FlgGameStart = True
      ElseIf GetAsyncKeyState(VK_RETURN) 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()
  Call displayTitle(True)
  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_SPACE) And &H8000 Then
        Call doStop
        Sleep (500)
      ElseIf GetAsyncKeyState(VK_RETURN) And &H8000 Then
        Call chudan
      End If
    Loop
  Loop
End Sub

'セル色、値の初期化や各種設定など、実行前準備
Sub junbi()
  RngMsg.Value = "Space とめる　Enter やめる"
  Call displayTitle(False)
  Range("G11").Value = ""
  FlgContinue = True
  RowPos = MAXROW + 1
  Haba = 0
  Call rowSettings
'  Migi = True
  BackColor = Sheets("設定").Range("B21").Interior.Color
  BlockColor = Sheets("設定").Range("B22").Interior.Color
  ErrColor = Sheets("設定").Range("B23").Interior.Color
  Range(Cells(MINROW, MINCOL), Cells(MAXROW, MAXCOL)) _
    .Interior.Color = BackColor
End Sub

'次の段での設定
Sub rowSettings()
  Dim kariHaba As Long
  RowPos = RowPos - 1
  RoopTime = Sheets("設定").Cells(RowPos, 3) '速さ
  kariHaba = Sheets("設定").Cells(RowPos, 2) '　幅
  If Haba > kariHaba Or Haba = 0 Then
    Haba = kariHaba
  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
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 "残念"
      Call displayGameOver
      FlgContinue = False
      Exit Sub
    End If
  End If
  If RowPos = MINROW Then
    RngMsg.Value = ""
    Call gohoubi  'ご褒美画面
    FlgContinue = False
  Else
    Call rowSettings  '次の段の設定
  End If
End Sub

'タイトル表示（true: 表示　false: 非表示）
Sub displayTitle(flg As Boolean)
  Select Case flg
    Case True
      Range("G4").Value = "Excel"
      Range("G6").Value = "ブロックつみ"
    Case False
      Range("G4").Value = ""
      Range("G6").Value = ""
  End Select
End Sub

'ゲームオーバー
Sub displayGameOver()
  Dim i As Long
  Dim cnt As Long
  Dim r As Range
  cnt = MAXROW - RowPos
  For i = 0 To cnt
    Sleep (100)
    Set r = Range(Cells(RowPos + i, MINCOL), Cells(RowPos + i, MAXCOL))
    r.Interior.Color = BackColor
  Next
  Range("G11").Value = "GAME OVER"
  Call displayTitle(True)
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.Color
    Select Case cl
      Case BlockColor   '重なっている
        r.Interior.Color = 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.Color = ErrColor
    Sleep (30)
    r.Interior.Color = BackColor
    Sleep (30)
  Next
End Sub

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

'ご褒美画像
Sub gohoubi()
  Dim r(2) As Range
  Dim myRange As Range
  Dim i As Long
  Set r(0) = Sheets("画面パターン").Range("B2:S35")
  Set r(1) = Sheets("画面パターン").Range("U2:AL35")
  Set r(2) = Sheets("画面パターン").Range("AN2:BE35")
  Set myRange = Sheets("ゲーム画面").Range("C3:K19")
'  Application.ScreenUpdating = False
  For i = 0 To 2
    r(i).CopyPicture
    ActiveSheet.Paste
    With Selection
      .Height = myRange.Height
      .Width = myRange.Width
      .Top = myRange.Top
      .Left = myRange.Left
      .Name = "img" & i
    End With
  Next
  ActiveSheet.Shapes("dummy").Select
  Application.ScreenUpdating = True
  Call imgKirikae
End Sub

'画像切り替え
Sub imgKirikae()
  Dim i As Long
  Dim l As Long
  l = ActiveSheet.Shapes("img1").Left
  Sleep (2000)
  ActiveSheet.Shapes("img2").Left = l + 10000
  For i = 0 To 10
    Select Case i Mod 2
      Case 1
        ActiveSheet.Shapes("img1").Left = l + 10000
      Case Else
        ActiveSheet.Shapes("img1").Left = l
    End Select
    DoEvents
    Application.ScreenUpdating = True
    Sleep (500)
  Next
  Sleep (2000)
  Call eraseImages
End Sub

'img という名前のshapeを消す
Sub eraseImages()
  Dim s As Shape
  For Each s In ActiveSheet.Shapes
    If InStr(s.Name, "img") > 0 Then
      s.Delete
    End If
  Next
End Sub

こんな感じです。

ご褒美画像に意外と力を入れていることがおわかりいただけるでしょうか。

画像の切り替えは、上に重なっている画像を

  1. 最背面に送る
  2. 透明にする（Visibleをfalseに）
  3. 表示されている範囲外の位置に飛ばす

の中から、一番安定していた(3)にしました。*1

今後の予定

とりあえず完成に近いところまで来ているので、もう少しテストして、コードを見直して、どこかに置こうと思います。

次回で終わります。*2

*1:どうして差が出るのかはよくわかりません

*2:たぶん