Excelでブロック積みゲームを作る　v1.0.0 配布の巻

ゲームの説明
動作環境
操作方法
ファイルのダウンロード
はじめの準備
- 編集を有効にする
- コンテンツの有効化
設定
諸注意とか
使用ソフト、サービス等
参考ページ
質問、ご意見等
コード
コード

ゲームの説明

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

左右に動くブロックを積み上げていくゲームです。

動作環境

Excel2016 で動作確認済です。

Excel2007以降であれば大丈夫なのではと思いますが、動作報告いただければ助かります。

操作方法

Startボタンをクリックすると、ゲームがスタートします。（キー入力を受け付けるようになります）

Enterキー　：　中断
Spaceキー　：　動くブロックを止める

※終了させる時はEnterキーで中断してから、ファイルを閉じてください。

ファイルのダウンロード

Excelブロック積み_v1_0_0.xlsm - Google ドライブ

上記リンク先からダウンロードしてください。

できなかったらゴメンナサイ。

はじめの準備

ファイルを開いたときになんだかメッセージが出てきたら、以下を実行してください

編集を有効にする

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

保護ビューで開いた場合、「編集を有効にする」をクリック

コンテンツの有効化

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

セキュリティの警告が出たら、「コンテンツの有効化」をクリック

設定

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

設定シートで、ブロックの幅と動く速さ、色などを設定できます。

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

画面パターンシートで、クリア後のご褒美画面を設定しています。

セル範囲を画像として貼り付けているだけなので、同じ範囲で画像を貼り付ければ差し替えられます（たぶん）

諸注意とか

ファイルの改変、再配布は自由です（特に断りもいりません）
ファイルをダウンロード、開いたことによるいかなる損害も当サイトは責任は負えません

使用ソフト、サービス等

ファミコン風のドット「FAMania」を使わせていただいています。

参考ページ

www1.plala.or.jp

home.att.ne.jp

参考にさせていただきました。ありがとうございます。

質問、ご意見等

コメントに残していただくか、ホームページの問い合わせからお願いします。

コード

前回

vba-belle-equipe.hatenablog.com

から、

コメント追加
不要コード削除
設定適用（簡易エラーチェック）

あたりが変更されています。

コード

'///シートモジュール（ゲーム画面シート）///

Private Sub btnStart_Click()
  Application.EnableEvents = False
  ActiveSheet.Shapes("dummy").Select
  Call eraseImages  '念のため画像を消す
  Call waitingStart
  Application.EnableEvents = True
End Sub


'///シートモジュール（設定シート）///

Private Sub btn設定適用_Click()
  If isSettingsOK = False Then
    Exit Sub
  End If
  Call defaultGamen
End Sub


'///標準モジュール///

Option Explicit

Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
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 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]

Public FlgGameStart As Boolean  'ゲームのスタートフラグ
Public FlgGameEnd As Boolean    'ゲームの終了フラグ
Public FlgContinue As Boolean   'ゲーム1回分の続行フラグ
Public ColPos As Long  '動くブロックの横位置
Public RowPos As Long  '動くブロックの縦位置
Public Haba As Long    '動くブロックの幅
Public BlockRange As Range  '動くブロックの範囲
Public RoopTime As Long     '動くブロックの速さ
Public Migi As Boolean '方向（true:右方向）
Public Kaisu As Long   '1回のキー入力で実行された回数（2回以上実行しないように）
Public BackColor As Long  '背景色
Public BlockColor As Long '動くブロックの色
Public ErrColor As Long   '失敗時の色
Public RngMsg As Range   'メッセージ表示エリア
Public RngGameOver As Range   'ゲームオーバーメッセージ表示エリア

'スタート待ち
Sub waitingStart()
  Dim StartTime As Long
  Dim tenmetuTime As Long
  tenmetuTime = 500   '点滅時間指定（ミリ秒）
  FlgGameStart = False
  FlgGameEnd = False
  Set RngMsg = Range("C2")
  Set RngGameOver = Range("G11")
  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)
  RngGameOver.Value = ""
  FlgContinue = True
  RowPos = MAXROW + 1
  Haba = 0
  Call rowSettings
  With Sheets("設定")
    BackColor = .Range("B21").Interior.Color
    BlockColor = .Range("B22").Interior.Color
    ErrColor = .Range("B23").Interior.Color
  End With
  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
  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
  Call cellMove
  DoEvents
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 doStop()
  Kaisu = Kaisu + 1
  If RowPos <> MAXROW Then
    If kasanari = False Then
      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
  RngGameOver.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 gohoubi()
  Dim r(2) As Range
  Dim myRange As Range
  Dim i As Long
  With Sheets("画面パターン")
    Set r(0) = .Range("B2:S35")
    Set r(1) = .Range("U2:AL35")
    Set r(2) = .Range("AN2:BE35")
  End With
  Set myRange = Sheets("ゲーム画面").Range _
        (Cells(MINROW, MINCOL), Cells(MAXROW, MAXCOL))
  'ゲーム画面にご褒美画像を貼り付ける
  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 changeImages
End Sub

'画像切り替え
Sub changeImages()
  Dim i As Long
  Dim posL As Long  'デフォルトの横位置
  posL = ActiveSheet.Shapes("img1").Left
  Sleep (2000)
  ActiveSheet.Shapes("img2").Left = posL + 10000
  For i = 0 To 10
    Select Case i Mod 2
      Case 1
        ActiveSheet.Shapes("img1").Left = posL + 10000
      Case Else
        ActiveSheet.Shapes("img1").Left = posL
    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

'設定チェック
Function isSettingsOK() As Boolean
  Dim checkRange As Range
  Dim r As Range
  Dim buf As String
  Dim cnt As Long
  Set checkRange = Sheets("設定").Range("B3:C19")
  checkRange.Interior.ColorIndex = xlNone
  cnt = 0
  For Each r In checkRange
    buf = r.Value
    If IsNumeric(buf) = False Then
      cnt = cnt + 1
      r.Interior.ColorIndex = 3
    End If
  Next
  If cnt > 0 Then
    MsgBox "ブロック数、速さ（ミリ秒）には数字を入力してください"
    isSettingsOK = False
  Else
    isSettingsOK = True
  End If
End Function

'ゲーム画面初期化
Sub defaultGamen()
  Dim myRange As Range
  Sheets("ゲーム画面").Activate
  Set RngMsg = Range("C2")
  Set RngGameOver = Range("G11")
  RngMsg.Value = "Startボタンをおしてください"
  RngGameOver.Value = ""
  BackColor = Sheets("設定").Range("B21").Interior.Color
  Set myRange = Sheets("ゲーム画面").Range _
      (Cells(MINROW, MINCOL), Cells(MAXROW, MAXCOL))
  myRange.Interior.Color = BackColor
  Call displayTitle(True)
End Sub