その昔 倉庫番 というゲームがありました。
Excelで完全に再現することは不可能ですが、できるだけ再現してみたいと思います。
ゲームプログラミングを勉強したい方には、あまり参考にならないと思います。
しかし、VBAの学習に多少寄与できるよう無駄なことをしながら挑戦してみます。
途中で挫折するかもしれませんので、ご承知ください。
ゲーム開始時でのおおまかなアルゴリズム
前回記事の続きです。
テンプレートとなる画像（シェイプ）はすでに用意されている前提です。
画像ファイルを使用しない場合は、色を塗ったり値をセットしたりなどで読み替えてください。
ゲーム開始時の動きは、ギブアップして最初からやり直す動きと同じです。
初期表示を構築するには
- 初期表示（設計図）情報を生成
- それに基づき、マップ上に画像生成
となります。
ただ、やり直し時にはその時点の状態の画像が残っているので、画像（再）表示前に画像を消去する必要があります。
ゲーム開始時の状態も画像有無はわからないので、画像消去処理はゲーム開始時も共通です。
壁は移動することはないので消去しないという方法もありますが、ここでは壁も含めてすべて消去し、再構築することとします。
そこで、
- 既存画像消去
- 初期表示（設計図）情報生成（作成済）
- マップ上に画像生成
という構成で作成します。
なお、コードは標準モジュールに記述します。
定数の用意
それぞれのコードの前に、用意している定数を紹介します。
'定数定義 Const C_INIT_PRSN_ROW As Integer = 3 '初期作業者位置（行） Const C_INIT_PRSN_COL As Integer = 5 '初期作業者位置（列） Const C_PIC_TYP_WALL As String = "壁" 'テンプレートシェイプ「壁」 Const C_PIC_TYP_GOAL As String = "的" 'テンプレートシェイプ「目的地」 Const C_PIC_TYP_CRATE As String = "荷" 'テンプレートシェイプ「荷物（未）」 Const C_PIC_TYP_DONE As String = "済" 'テンプレートシェイプ「荷物（済）」 Const C_SHAPE_NAME_PRFX As String = "Pict" 'マップ内シェイプ名接頭語 Const C_SHAPE_WHS_PRSN As String = "WH-WORKER" '作業者のシェイプ名
「シェイプ名の接頭語」はのちほど説明します。
テンプレートとなる画像（シェイプ）は、ほかに作業者用も用意しています。
しかし、作業者テンプレートシェイプの定数を用意していません。
「上」「右」「下」「左」はテンプレートのシェイプ名であると同時に、移動方向を示す引数（パラメータ）にも今後利用する予定です。
２つの意味をもつこれらの文言は、定数にせず直接コードに記述していきます。
マップ上に初期状態の画像を生成
画像を利用する方だけですが、64bitマシーンの場合モジュールレベル領域にこのコードを Copy&Paste してください。
32bitマシーンの場合少しコードが違うので、調べてください。
Option Explicit '64bit PC Private Declare PtrSafe _ Sub Sleep Lib "kernel32.dll" (ByVal ms As LongPtr)
構造体情報を読み込んで、マップと同一シート上にあるテンプレートシェイプをコピーして該当のセルに貼り付けるという作業です。
生成するシェイプは、セルと同様特定できるように一意な名前を持たせます。
ネーミングルールとして「 シェイプ名の接頭語 + 2桁行番号 + 2桁列番号 」とします。
シェイプ名を生成するユーザー定義関数をグローバルレベルで用意します。
'---------------------------------------------------------------------- ' g_fnCrtShapeName ' 行番号を2桁に列番号を2桁にして、一意なシェイプ名を作る ' 引数 = in_intRow : 行番号 ' 引数 = in_intCol : 列番号 ' 戻り値 = シェイプ名 '---------------------------------------------------------------------- Public Function g_fnCrtShapeName _ (in_intRow As Integer, in_intCol As Integer) As String g_fnCrtShapeName = C_SHAPE_NAME_PRFX & _ Format(in_intRow, "00") & Format(in_intCol, "00") End Function
"g_"とすることで、グローバルレベルであることを意味します。
引数（パラメータ）であることを意味する"p_"を使ってもいいのですが、参照渡し（ByRef）を利用して引数を戻り値にする場合と区別して"in_"としています。
ここからは画像を使わない方は適宜置き換えてください。
テンプレートをコピーしてセルの上に貼り付けるという作業は、初期表示だけでなくプレー中の動きでも利用するので、共通プロシージャとして用意します。
まず、いったんコードを作成します。
'---------------------------------------------------------------------- ' sbCreatePic ' シェイプをコピーして生成する ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_obgRange : ピクチャを生成したいセル ' 引数 = in_strFromName : コピー元シェイプ名 ' 引数 = in_strToName : 生成するシェイプにつける名前 '---------------------------------------------------------------------- Sub sbCreatePic(in_objSheet As Worksheet, in_objRange As Range, _ in_strFromName As String, in_strToName As String) in_objSheet.Shapes(in_strFromName).Copy in_objRange.PasteSpecial Application.CutCopyMode = False Selection.Name = in_strToName in_objRange.Select 'コピー時や貼り付け時のエラー回避 Sleep 100 DoEvents End Sub
引数に Range オブジェクトがありますが、こちらは範囲でなく１つのセルが入ります。
Cells はオブジェクトがないため Range を使用します。
引数（パラメータ）に、セルとシェイプ名でなく行番号と列番号にして、サブルーチン内でシェイプ名を生成する形でもいいです。
途中 Sleep と DoEvents とありますが、オブジェクトを Copy&Paste する際のエラー回避のおまじないのようなものなので、画像を使わない方は不要です。
私はあまり詳しくないのですが、クリップボードに保持する処理がExcel側でなくWindows側のために高速で処理が走るとエラーになるみたいです。
なお Sleep はVBA標準でないため、 API を呼び出すコードをモジュールレベル領域に記述しました。
ただ、残念ながら私の環境では ABnormal-END が頻発してしまい、エラーハンドリングしています。
最終的なコードはこちらです。
'---------------------------------------------------------------------- ' sbCreatePic ' シェイプをコピーして生成する ' 引数 = in_objSheet : シートオブジェクト ' 引数 = in_obgRange : ピクチャを生成したいセル ' 引数 = in_strFromName : コピー元シェイプ名 ' 引数 = in_strToName : 生成するシェイプにつける名前 '---------------------------------------------------------------------- Sub sbCreatePic(in_objSheet As Worksheet, in_objRange As Range, _ in_strFromName As String, in_strToName As String) On Error GoTo WorkAround in_objSheet.Shapes(in_strFromName).Copy in_objRange.PasteSpecial Application.CutCopyMode = False Selection.Name = in_strToName in_objRange.Select 'コピー時や貼り付け時のエラー回避 Sleep 100 DoEvents Exit Sub WorkAround: MsgBox Err.Number & vbCrLf & Err.Description Resume End Sub
単純にエラーを無視するだけというのは怖いので、念のためメッセージ表示はしています。
下準備ができたので、作業者以外のマップ画像を生成する sbReGene を作ります。
'---------------------------------------------------------------------- ' sbReGene ' 目的地、荷物を再生成する ' 引数 = in_objSheet : シートオブジェクト '---------------------------------------------------------------------- Sub sbReGene(in_objSheet As Worksheet) Dim intRow As Integer Dim intCol As Integer Dim objRange As Range Dim strShapeID As String 'シェイプ名 For intRow = C_MIN_ROW To C_MAX_ROW For intCol = C_MIN_COL To C_MAX_COL Set objRange = in_objSheet.Cells(intRow, intCol) strShapeID = g_fnCrtShapeName(intRow, intCol) '壁描画 If m_typCellInfo(intRow, intCol).HasWALL Then Call sbCreatePic(in_objSheet, _ objRange, C_PIC_TYP_WALL, strShapeID) End If '目的地描画 If m_typCellInfo(intRow, intCol).HasGOAL And _ Not m_typCellInfo(intRow, intCol).HasCRATE Then Call sbCreatePic(in_objSheet, _ objRange, C_PIC_TYP_GOAL, strShapeID) End If '荷物（未到）描画 If m_typCellInfo(intRow, intCol).HasCRATE And _ Not m_typCellInfo(intRow, intCol).HasGOAL Then Call sbCreatePic(in_objSheet, _ objRange, C_PIC_TYP_CRATE, strShapeID) End If ' ' '荷物（済）描画 ' If m_typCellInfo(intRow, intCol).HasCRATE And _ ' m_typCellInfo(intRow, intCol).HasGOAL Then ' Call sbCreatePic(in_objSheet, _ ' objRange, C_PIC_TYP_DONE, strShapeID) ' End If Next intCol Next intRow End Sub
作業者は１つだけなので、シェイプ名はセル位置と無関係に固定値にします。
ゲーム開始地点でもあるため、シェイプを生成するとともにそのセル位置を返します。（左向きにしていることには特に意味はありません。）
'---------------------------------------------------------------------- ' fnCreateWorker ' ゲーム開始時の位置に作業者を生成する ' 引数 = in_objSheet : シートオブジェクト ' 戻り値 = 開始時点の作業者セル '---------------------------------------------------------------------- Function fnCreateWorker(in_objSheet As Worksheet) As Range Dim objRange As Range '作業者描画 Set objRange = in_objSheet.Cells(C_INIT_PRSN_ROW, C_INIT_PRSN_COL) Call sbCreatePic(in_objSheet, objRange, "左", C_SHAPE_WHS_PRSN) '戻り値セット Set fnCreateWorker = objRange End Function
マップ内の既存画像を消去
前述のとおり、壁も含めたシェイプすべてを削除します。
シート上のすべてのシェイプを対象とする場合は For Each ループ を使います。
一般的にもブック内のすべてのシートに対する処理など、オブジェクトを対象とするループ処理でよく利用されます。
あまり使う機会はありませんが、Variant変数に対しても使えます。
シート上のシェイプの中でも、テンプレートは削除したくありません。
また、説明書きをテキストボックスで作成している場合も削除されては困ります。
そのため、シェイプ名の接頭語がついているものと作業者のシェイプのみを削除対象とします。
シェイプを削除する sbClearShapes のコードです。
'---------------------------------------------------------------------- ' sbClearShapes ' マップ内の壁、目的地、荷物、作業者を消す ' 引数 = in_objSheet : シートオブジェクト '---------------------------------------------------------------------- Sub sbClearShapes(in_objSheet As Worksheet) Dim objPic As Shape Dim intLen As Integer intLen = Len(C_SHAPE_NAME_PRFX) For Each objPic In in_objSheet.Shapes If objPic.Name = C_SHAPE_WHS_PRSN Or _ Left(objPic.Name, intLen) = C_SHAPE_NAME_PRFX Then objPic.Delete End If Next objPic End Sub
ゲーム開始時とやり直し時の処理
材料はできあがりましたので、いったん Macro1 としてゲーム開始時とやり直し時の共通処理コードを作成します。
'---------------------------------------------------------------------- ' fnRefresh ' 構造体リセットや画面初期表示を行う ' 引数 = in_objSheet : シートオブジェクト ' 戻り値 = 作業者初期配置のセル（オブジェクト） '---------------------------------------------------------------------- Sub Macro1() Dim objRange As Range '画面反映停止 ' Application.ScreenUpdating = False '画像クリア Call sbClearShapes(ActiveSheet) '構造体初期化 Erase m_typCellInfo 'ステップ数初期化 in_objSheet.Cells(C_CNT_STEP_ROW, C_CNT_STEP_COL) = 0 '各セルの情報を持つ構造体を生成 Call sbStatusInfo '画像再描画 Call sbReGene(ActiveSheet) '初期位置で倉庫作業者セルを定義 Set objRange = fnCreateWorker(ActiveSheet) '作業者セルを選択 objRange.Select '画面反映再開 ' Application.ScreenUpdating = True End Sub
共通処理なので、あとで引数と戻り値をもつ ユーザー定義関数 に書き換えます。
Application.ScreenUpdatingはコメントアウトしていますが、VBAではよく使います。
プログラム処理内容をエクセル画面に反映させないことより、処理時間を短縮できます。
次回は、ギブアップによるやり直し機能やゲームの途中終了機能を実装していきます。
ご質問は下の 「コメントを書く」 からお願いします。
ExcelやVBA全般に関わる質問で、比較的簡単にお答えできるものはできる限り回答したいと思います。
回答を公開でなくメールでやり取りしたいという場合は、その旨記載していただければ非公開で回答することも可能です。
有償での作業依頼は非公開にしますので、条件等をお知らせください。
