その昔 倉庫番 というゲームがありました。
Excelで完全に再現することは不可能ですが、できるだけ再現してみたいと思います。
ゲームプログラミングを勉強したい方には、あまり参考にならないと思います。
しかし、VBAの学習に多少寄与できるよう無駄なことをしながら挑戦してみます。
途中で挫折するかもしれませんので、ご承知ください。
荷物移動の実装
前回記事の続きです。
荷物移動の前にクリア条件を確認します。
荷物のすべてを目的地までの運び終えるとゲームクリアと同時にゲーム終了となります。
そのため、まだ目的地に到達していない荷物の数を残数として管理し、残数がゼロになるとループから抜け出しゲーム終了する処理にします。
本来、残数はエクセルの非表示セルで管理するのがいいと思いますが、今回はモジュールレベル変数での管理にします。
'ゲームクリアまでの残数 Private m_intRest As Integer
荷物を移動する場合は、構造体情報の更新も必要になります。
残数更新の機能も含めて、荷物移動処理のコードを作成します。
'---------------------------------------------------------------------- ' sbMoveCrate ' 荷物の移動処理 ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_clsCrate : 荷物のクラスインスタンス '---------------------------------------------------------------------- Sub sbMoveCrate(in_objSheet As Worksheet, in_clsCrate As clsCell) Dim intRow As Integer Dim intCol As Integer With in_clsCrate '現在の荷物画像を削除 in_objSheet.Shapes(.sShpName_0).Delete 'ふたつ先が目的地なら画像を削除 intRow = .oRange_1.Row intCol = .oRange_1.Column If .bGoal_1 Then in_objSheet _ .Shapes(g_fnCrtShapeName(intRow, intCol)).Delete Sleep 100 DoEvents End If 'ふたつ先に荷物を生成 Call sbCreatePic _ (in_objSheet, .oRange_1, .sPicType_1, .sShpName_1) '構造体のセル情報を更新 m_typCellInfo(intRow, intCol).HasCRATE = True intRow = .oRange_0.Row intCol = .oRange_0.Column m_typCellInfo(intRow, intCol).HasCRATE = False '荷物（済）の出or消で、クリアまでの残数を更新 If Not .bGoal_0 And .bGoal_1 Then m_intRest = m_intRest - 1 If .bGoal_0 And Not .bGoal_1 Then m_intRest = m_intRest + 1 End With End Sub
作業者が移動できないときの処理
移動できないときは何もしなくてもよいのですが、押されたキーにより画像を切り替えることはやっておきます。
移動できないときになんらかの通知もしたいのですが、さすがに毎度メッセージを出すのはうっとうしいので、ビープ音を出すようにします。
ただ、ビープ音を出すためにはまたAPIの力を借りなくてはいけないので、標準モジュールのモジュールレベル領域に以下のコードを追加します。
Private Declare PtrSafe Function Beep Lib _ "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
処理コードです。
'---------------------------------------------------------------------- ' sbExecAtDeadEnd ' 行き止まりの時に、警告音を出し、作業者シェイプを生成 ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_objRange : 作業者の移動前セル ' 引数 = in_strDrct : 移動方向 -> 上or右or下or左 '---------------------------------------------------------------------- Sub sbExecAtDeadEnd(in_objSheet As Worksheet, _ in_objRange As Range, in_strDrct As String) '作業者の既存シェイプを削除 in_objSheet.Shapes(C_SHAPE_WHS_PRSN).Delete Sleep 100 DoEvents '作業者のシェイプを生成 Call sbCreatePic(in_objSheet, in_objRange, _ in_strDrct, C_SHAPE_WHS_PRSN) Beep 440, 500 in_objRange.Select End Sub
作業者移動の実装
すでに無条件に移動させましたが、追加するのは現在または移動先が目的地だった場合の処理です。
早速ステップ数セル更新も含めたコードです。
'---------------------------------------------------------------------- ' sbMoveWroker ' 作業者の移動処理 ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_strDrct : 移動方向 -> 上or右or下or左 ' 引数 = in_clsPrsn : 荷物のクラスインスタンス '---------------------------------------------------------------------- Sub sbMoveWorker(in_objSheet As Worksheet, _ in_strDrct As String, in_clsPrsn As clsCell) Dim intRow As Integer Dim intCol As Integer With in_clsPrsn '作業者の既存シェイプを削除 in_objSheet.Shapes(.sShpName_0).Delete Sleep 100 DoEvents '移動前セルが目的地なら、シェイプを復活する If .bGoal_0 Then intRow = .oRange_0.Row intCol = .oRange_0.Column Call sbCreatePic(in_objSheet, .oRange_0, _ C_PIC_TYP_GOAL, g_fnCrtShapeName(intRow, intCol)) End If '移動先シェイプが目的地ならシェイプを削除 If .bGoal_1 And Not .bCrate_1 Then intRow = .oRange_1.Row intCol = .oRange_1.Column in_objSheet. _ Shapes(g_fnCrtShapeName(intRow, intCol)).Delete Sleep 100 DoEvents End If '移動先に作業者シェイプを生成 Call sbCreatePic(in_objSheet, .oRange_1, _ in_strDrct, .sShpName_0) End With 'ステップ数カウントアップ With in_objSheet.Cells(C_CNT_STEP_ROW, C_CNT_STEP_COL) .Value = .Value + 1 End With End Sub
矢印キーが押されたときの処理（全体）の完成
以前 "fnTempFunc" という名前で矢印キーが押されたときに呼び出す関数を作成しましたが、完成した情報収集と移動処理を呼び出して、関数の名前も変えて完成させます。
コードです。
'---------------------------------------------------------------------- ' fnExecByCursorKey ' 矢印キーが押された時の動作 ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_objRange : 移動前セルのオブジェクト ' 引数 = in_strDrct : 移動方向 -> 上or右or下or左 ' 戻り値 = 移動後のセル（オブジェクト） '---------------------------------------------------------------------- Function fnExecByCursorKey(in_objSheet As Worksheet, _ in_objRange As Range, in_strDrct As String) As Range Dim blnMovable As Boolean '作業者セル用のインスタンス Dim clsPrsn As clsCell '荷物セル用のインスタンス Dim clsCrate As clsCell blnMovable = True '作業者セル処理情報を取得 ' この時点で作業者セルが目的地かどうかわからない Set clsPrsn = fnSetPropertis(in_objRange, in_strDrct, _ False, PC_PARM_CELL_WORKER) '作業者セルが目的地かどうか With clsPrsn.oRange_0 clsPrsn.bGoal_0 = m_typCellInfo(.Row, .Column).HasGOAL End With With clsPrsn If .bMovable Then '作業者の先が荷物なら、荷物セル処理情報を取得 If .bCrate_1 Then Set clsCrate = _ fnSetPropertis(.oRange_1, in_strDrct, _ .bGoal_1, PC_PARM_CELL_CRATE) If clsCrate.bMovable Then '移動条件を満たせば、荷物を移動する Call sbMoveCrate(in_objSheet, clsCrate) Set clsCrate = Nothing Else '荷物の先が壁か荷物なら移動不可 blnMovable = False End If End If Else '作業者の先が壁なら移動不可 blnMovable = False End If End With '作業者シェイプに対して If Not blnMovable Then '移動不可処理を実行 Call sbExecAtDeadEnd(in_objSheet, in_objRange, in_strDrct) '移動後のセルを戻り値にセット Set fnExecByCursorKey = in_objRange Else '作業者を移動する Call sbMoveWorker(in_objSheet, in_strDrct, clsPrsn) '移動後のセルを戻り値にセット With clsPrsn .oRange_1.Select Set fnExecByCursorKey = .oRange_1 End With End If Set clsPrsn = Nothing End Function
これでほぼ完成していますので、次回はゲームクリアを実装し最終回とします。
ご質問は下の 「コメントを書く」 からお願いします。
ExcelやVBA全般に関わる質問で、比較的簡単にお答えできるものはできる限り回答したいと思います。
回答を公開でなくメールでやり取りしたいという場合は、その旨記載していただければ非公開で回答することも可能です。
有償での作業依頼は非公開にしますので、条件等をお知らせください。
