【VBA】オートシェイプで3D迷路を作ってみる(後編)
<機能>
(1)VBAで3D迷路(プチゲーム)を作ってみる 後編 です
前回は3Dマップ表示まで行いました
(前回 オートシェイプで3D迷路を作ってみる(前編) )
今回はコマンドボタン(前、左、右)によって移動できます
感動のエンディング www もご覧ください
(2)マップ表示はオートシェイプを使用します
(3)全体マップと3D表示マップを実装しました
全体マップ:20×20の全体マップです(スタートとゴールに●を表示します)
3Dマップ:縦8階層×横9ブロックの3D表示の元データです
(4)3Dマップは常にユーザの正面目線で描画しています
全体マップで北向きのとき:ユーザの現在位置の上側を描画
全体マップで東向きのとき:ユーザの現在位置の右側を描画
全体マップで南向きのとき:ユーザの現在位置の下側を描画
全体マップで西向きのとき:ユーザの現在位置の左側を描画
(5)コマンドボタンは「前進む」「左向く」「右向く」を実装しました
(6)3D表示エリアは64セル×64セルです
正面(後方)の壁の四角形、横壁の台形表示とセル数との関係は以下の通りです
(7)前回の3Dマップ描画で壁が足りなかった部分を修正しました
四角形と台形の表示処理
1)壁(情報コード=9、99)のときの3D描画
・描画対象外(目に見えない範囲 情報コード=7、8)ならスキップ
・手前の壁(四角形)を描画する
2)通路(情報コード=1、2、0)のときの3D描画
・中央より左(0から3)のとき、左が壁なら左側に台形を描画
・中央より右(5から7)のとき、右が壁なら右側に台形を描画
・中央(4)のとき左が壁なら左側、右が壁なら右側、両方なら両方に台形を描画
3)通路のとき前のブロックが壁なら前面に四角形を描画
<実行イメージ>
YouTubeに動画アップしましたのでご覧ください
<動作検証>
Microsoft Office 2016
<使い方>
適当なところにソースを貼り付けてください
シート初期化() を実行すると3D迷路を描画します
※アクティブセルの情報を全てクリアしますのでご注意ください
ソースは3Dマップ描画部のみ掲載します
下記URLで完全版を公開しております
http://sagami-ss.sub.jp/pg-sample/src/Excel_3DMaze_SourceCode.txt
Private Const D_WIDTH# = 3#
Private Const D_HEIGHT# = 17#
'//3D迷路エリアのセル数(縦横共通)
Private Const D_MAPCELL = 64
'// マップ情報(9:壁 8:描画範囲外(壁) 7:描画範囲外(通路) 0:通路 1:スタート 2:ゴール)
Type sctmap
info As Integer 'マップ情報
span As Integer 'マップを描画するときのセル幅(高さは中央の幅と同じ)
twidth As Integer '台形を描画するときの幅
End Type
Private map(7, 8) As sctmap
Type sctrect
NW(1) As Integer
SW(1) As Integer
SE(1) As Integer
NE(1) As Integer
End Type
Private bSetting As Boolean
'//全体マップ格納配列
Private allmap(19, 19) As Integer
'//現在位置を格納(全体マップ内の絶対座標)
Private gyoPos As Integer
Private clmPos As Integer
Private old_gyoPos As Integer
Private old_clmPos As Integer
'//向いている方向("N":北/"E":東/"S":南/"W":西)
Private cos As String
'/ マップ情報に従い迷路を描画する
'/*********************************************
Private Sub 迷路描画処理()
On Error GoTo Error_MapView
Dim i As Integer, j As Integer
Dim srect() As sctrect
Application.ScreenUpdating = False
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
'描画範囲外(8:壁 7:通路)はスキップ
If map(i, j).info = 8 Or map(i, j).info = 7 Then
GoTo nextrec
End If
'壁(map.info=9)、全体マップ範囲外(99)のときの描画処理
If map(i, j).info = 9 Or map(i, j).info = 99 Then
If (i <> 0) Then
'台形描画
図形座標取得 i, j, "Trapezoid", srect
図形描画 srect, map(i, j).info
End If
'ゴールにたどり着いたら全体マップ範囲外中央の図形を描画しない
If allmap(gyoPos, clmPos) = 2 And j = 4 Then
'描画なし
Else
'台形を描画してから手前の壁を描画する
図形座標取得 i, j, "Rectangle", srect
図形描画 srect, map(i, j).info
End If
GoTo nextrec
End If
'台形描画
'最後尾(i=0)は台形描画なし
If i <> 0 Then
'中央より左(j < 4)のときは左が壁(info=9or8)なら左詰めで描画
'中央より右(j > 4)のときは右が壁(info=9or8)なら右詰めで描画
'中央のときは左右の壁判定を行う
If ((j < 4) And (map(i, j - 1).info > 7)) Or _
((j > 4) And (map(i, j + 1).info > 7)) Or _
((j = 4) And (map(i, j - 1).info > 7 Or map(i, j + 1).info > 7)) Then
図形座標取得 i, j, "Trapezoid", srect
図形描画 srect, map(i, j).info
End If
End If
'通路で前面が壁の場合は前面壁の後壁を描画
'壁の時に後ろ壁を表示する方法だとZOrderがおかしいケースが発生するのでこちらの方法に変更した
If (i < UBound(map, 1)) Then
If (map(i, j).info < 7) And (map(i + 1, j).info > 7) Then
図形座標取得 i, j, "Rectangle", srect
図形描画 srect, map(i, j).info
End If
End If
nextrec:
Next
Next
Application.ScreenUpdating = True
End Sub
'/ 図形座標取得
'/ 現在位置に描画する四角形の座標を取得
'/ gyo:現在位置(縦)
'/ clm:現在位置(横)
'/ kind:"Rectangle":四角形 "Trapezoid":台形
'/ srect:描画座標を格納(中央のとき左右の台形を描画するときは配列要素を追加する)
'/*********************************************
Private Sub 図形座標取得(ByVal gyo As Integer, ByVal clm As Integer, _
ByVal kind As String, ByRef srect() As sctrect)
Dim i As Integer, j As Integer
Dim tmpW As Integer, tmpH As Integer, tmpL As Integer, tmpT As Integer
Dim idx As Integer
'//座標格納構造体配列を初期化
ReDim srect(1)
For i = 0 To 1
For j = 0 To 1
srect(i).NW(j) = 0
srect(i).SW(j) = 0
srect(i).SE(j) = 0
srect(i).NE(j) = 0
Next
Next
'//図形の幅と高さを取得(高さは中央の横幅と同じ)
tmpW = map(gyo, clm).span
tmpH = map(gyo, 4).span
'//図形の開始位置(Left位置)を取得
tmpL = 1
For j = 0 To clm - 1
tmpL = tmpL + map(gyo, j).span
Next
'//図形の開始位置(Top位置)を取得
tmpT = 1 + ((64 - map(gyo, 4).span) / 2)
idx = 0
Select Case kind
Case "Rectangle"
srect(0).NW(0) = tmpT
srect(0).NW(1) = tmpL
srect(0).SW(0) = tmpT + tmpH
srect(0).SW(1) = tmpL
srect(0).SE(0) = tmpT + tmpH
srect(0).SE(1) = tmpL + tmpW
srect(0).NE(0) = tmpT
srect(0).NE(1) = tmpL + tmpW
Case "Trapezoid"
'台形の幅(map.twidth)がセットされていなければ終了
If map(gyo, clm).twidth = 0 Then Exit Sub
'中央より左、または中央左側、または壁のとき
If (clm < 4) Or (clm = 4 And map(gyo, clm - 1).info > 7) Or _
(clm = 4 And map(gyo, clm).info = 9) Then
'右辺が短いのでSEとNEが変更となる
srect(0).NW(0) = tmpT
srect(0).NW(1) = tmpL
srect(0).SW(0) = tmpT + tmpH
srect(0).SW(1) = tmpL
srect(0).SE(0) = tmpT + tmpH - gyo
srect(0).SE(1) = tmpL + map(gyo, clm).twidth
srect(0).NE(0) = tmpT + gyo
srect(0).NE(1) = tmpL + map(gyo, clm).twidth
If clm = 4 Then idx = idx + 1
End If
'中央より右、または中央右側、または壁のとき
If (clm > 4) Or (clm = 4 And map(gyo, clm + 1).info > 7) Or _
(clm = 4 And map(gyo, clm).info = 9) Then
'左辺が短いのでNWとSWが変更となる(右詰めで描画)
srect(idx).NW(0) = tmpT + gyo
srect(idx).NW(1) = tmpL + (tmpW - map(gyo, clm).twidth)
srect(idx).SW(0) = tmpT + tmpH - gyo
srect(idx).SW(1) = tmpL + (tmpW - map(gyo, clm).twidth)
srect(idx).SE(0) = tmpT + tmpH
srect(idx).SE(1) = tmpL + tmpW
srect(idx).NE(0) = tmpT
srect(idx).NE(1) = tmpL + tmpW
Exit Sub
End If
End Select
End Sub
'/ 図形描画
'/ 四角形の座標を元にオートシェイプを描画
'/ srect:描画座標を格納(中央のとき左右の台形を描画するケースがある)
'/ mapinfo:マップ情報
'/*********************************************
Private Sub 図形描画(ByRef srect() As sctrect, ByVal mapinfo As Integer)
Dim i As Integer
Dim cw As Double, ch As Double
'セル1つの幅と高さ
cw = Range("A1").Width
ch = Range("A1").Height
For i = 0 To UBound(srect)
'座標が取得できていないとき(中央以外はインデックス1はない)描画しない
'NWで判定する
If srect(i).NW(0) = 0 Then Exit For
With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, cw * srect(i).NW(1), ch * srect(i).NW(0))
.AddNodes msoSegmentLine, msoEditingAuto, cw * srect(i).SW(1), ch * srect(i).SW(0)
.AddNodes msoSegmentLine, msoEditingAuto, cw * srect(i).SE(1), ch * srect(i).SE(0)
.AddNodes msoSegmentLine, msoEditingAuto, cw * srect(i).NE(1), ch * srect(i).NE(0)
.AddNodes msoSegmentLine, msoEditingAuto, cw * srect(i).NW(1), ch * srect(i).NW(0)
With .ConvertToShape
.Line.Weight = 8
'//全体マップ範囲外(99)、ゴール(2)、通常描画の色を分岐
If mapinfo = 99 Then
.Line.ForeColor.RGB = RGB(58, 58, 58)
'//四角形と台形で色を少し変える
If srect(i).NW(0) = srect(i).NE(0) Then
.Fill.ForeColor.RGB = RGB(84, 84, 84)
Else
.Fill.ForeColor.RGB = RGB(110, 110, 110)
End If
.Fill.Transparency = 0.1
ElseIf mapinfo = 2 Then
.Line.ForeColor.RGB = RGB(223, 34, 19)
'//四角形と台形で色を少し変える
If srect(i).NW(0) = srect(i).NE(0) Then
.Fill.ForeColor.RGB = RGB(255, 153, 255)
Else
.Fill.ForeColor.RGB = RGB(255, 153, 255)
End If
.Fill.Transparency = 0.3
Else
.Line.ForeColor.RGB = RGB(197, 90, 17)
'//四角形と台形で色を少し変える
If srect(i).NW(0) = srect(i).NE(0) Then
.Fill.ForeColor.RGB = RGB(191, 144, 0)
Else
.Fill.ForeColor.RGB = RGB(255, 224, 125)
End If
.Fill.Transparency = 0.3
End If
End With
Next
'/ マップデータを取得する
'/ マップ情報(9:壁 8:描画範囲外(壁) 7:描画範囲外(通路) 0:通路 1:スタート 2:ゴール)
'/*********************************************
Private Function マップデータ取得() As Boolean
Dim i As Integer, j As Integer
Dim stgyo As Integer, stclm As Integer
On Error GoTo Error_Map
マップデータ取得 = False
'//map配列を全体マップ範囲外(info=99)で初期化
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
map(i, j).info = 99
Next
Next
'//現在位置と向きからmap.infoエリアを取得する
'//描画可能範囲は□の位置、■は描画しない範囲となる
'//□□□□□□□□□
'//■□□□□□□□■
'//■□□□□□□□■
'//■■□□□□□■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■■□■■■■
Select Case cos
Case "N"
stgyo = gyoPos - 7
For i = 0 To UBound(map, 1) Step 1
stclm = clmPos - 4
For j = 0 To UBound(map, 2) Step 1
'全体マップ範囲外(99)は変更しない
If stclm >= 0 And stclm <= UBound(allmap, 2) And _
stgyo >= 0 And stgyo <= UBound(allmap, 1) Then
map(i, j).info = allmap(stgyo, stclm)
End If
stclm = stclm + 1
Next
stgyo = stgyo + 1
Next
Case "E"
stclm = clmPos + 7
For i = 0 To UBound(map, 1) Step 1
stgyo = gyoPos - 4
For j = 0 To UBound(map, 2) Step 1
'全体マップ範囲外(99)は変更しない
If stclm >= 0 And stclm <= UBound(allmap, 2) And _
stgyo >= 0 And stgyo <= UBound(allmap, 1) Then
map(i, j).info = allmap(stgyo, stclm)
End If
stgyo = stgyo + 1
Next
stclm = stclm - 1
Next
Case "S"
stgyo = gyoPos + 7
For i = 0 To UBound(map, 1) Step 1
stclm = clmPos + 4
For j = 0 To UBound(map, 2) Step 1
'全体マップ範囲外(99)は変更しない
If stclm >= 0 And stclm <= UBound(allmap, 2) And _
stgyo >= 0 And stgyo <= UBound(allmap, 1) Then
map(i, j).info = allmap(stgyo, stclm)
End If
stclm = stclm - 1
Next
stgyo = stgyo - 1
Next
Case "W"
stclm = clmPos - 7
For i = 0 To UBound(map, 1) Step 1
stgyo = gyoPos + 4
For j = 0 To UBound(map, 2) Step 1
'全体マップ範囲外(99)は変更しない
If stclm >= 0 And stclm <= UBound(allmap, 2) And _
stgyo >= 0 And stgyo <= UBound(allmap, 1) Then
map(i, j).info = allmap(stgyo, stclm)
End If
stgyo = stgyo - 1
Next
stclm = stclm + 1
Next
Case Else
Exit Function
End Select
'//描画範囲外のマップデータをセット
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
'行が可能範囲外なら強制的に描画範囲外の壁=8、描画範囲外の通路=7をセット
'("■"の箇所は強制的に8or7をセット)
GetMapValue i, j
Next
Next
マップデータ取得 = True
Error_Map:
Exit Function
End Function