【VBA】オートシェイプで3D迷路を作ってみる(前編)
<機能>
(1)VBAで3D迷路(プチゲーム)を作ってみます
今回は3Dを表示するところまでです
サンプルマップを5種類切り替えて表示します
次回、マップ上を移動できるようにするつもりです(お盆には完成させたい)
(2)3D迷路に必要な台形描画はオートシェイプを使用します
(3)3D迷路の仕様
(3)-1.マップの大きさは64×64セルとします
(3)-2.正面の壁、横の壁はオートシェイプを使用します
(3)-3.奥行きは8階層(インデックス0から7とし0が最奥、7が手前です)
・最奥は壁9ブロック、手前は壁1ブロック
・座標が通路でとなりが壁の時に横壁を表示します(台形を描画)
・横壁は中央より左の時は右辺が短い台形、中央より右の時は左辺が短い台形
(3)-4.描画は奥から順番に行います(結果として見えない壁も描画処理します)
(3)-5.階層別の壁と台形の表示位置は下図の通りです
・上の図の赤色分部が台形(横の壁)を描画するときの台形の幅
・下図の灰色分部がマップ表示されない部分(見えない部分)
<実行イメージ>
シート初期化()実行直後
下の画像を見るとまだまだ横の壁の表示処理が足りない、、、汗
次回、修正します
[次のサンプルマップ]押下によりサンプルが切り替わります
<動作検証>
Microsoft Office 2016
<使い方>
適当なところにソースを貼り付けてください
シート初期化() を実行すると3D迷路を描画します
※アクティブセルの情報を全てクリアしますのでご注意ください
'//セルの幅と高さ
Private Const D_WIDTH# = 3#
Private Const D_HEIGHT# = 17#
'//3D迷路エリアのセル数(縦横共通)
Private Const D_MAPCELL = 64
Private Const D_WIDTH# = 3#
Private Const D_HEIGHT# = 17#
'//3D迷路エリアのセル数(縦横共通)
Private Const D_MAPCELL = 64
'//マップ格納配列(7行9列)
'// マップ情報(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
'// マップ情報(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
Type sctrect
NW(1) As Integer
SW(1) As Integer
SE(1) As Integer
NE(1) As Integer
End Type
'//サンプル表示するマップの番号
Private sampleno As Integer
Private sampleno As Integer
'/*********************************************
'/ シートを初期化する
'/*********************************************
Public Sub シート初期化()
Dim i As Integer
'/ シートを初期化する
'/*********************************************
Public Sub シート初期化()
Dim i As Integer
'//確認メッセージ
stname = ActiveSheet.Name
iret = MsgBox("ブック: " & ThisWorkbook.Name & vbCrLf & _
"シート: " & stname & vbCrLf & "3D迷路表示用に初期化してもよろしいですか?" & _
vbCrLf & "(シートのすべてのセル情報がクリアされます)", _
vbYesNo + vbExclamation, "3DマップMacro")
If iret = vbNo Then Exit Sub
'//シートをクリアする
シートクリア stname
'//3Dマップ表示エリア(64×62)を生成
For i = 2 To D_MAPCELL + 1
Cells(1, i) = i - 1
Cells(2 + D_MAPCELL, i) = i - 1
Cells(i, 1) = i - 1
Cells(i, 2 + D_MAPCELL) = i - 1
Next
Range("B1:E1").Interior.Color = RGB(255, 217, 102)
Range("A2:A5").Interior.Color = RGB(255, 217, 102)
Range("N1:U1").Interior.Color = RGB(255, 217, 102)
Range("A14:A21").Interior.Color = RGB(255, 217, 102)
Range("AD1:AK1").Interior.Color = RGB(255, 217, 102)
Range("A30:A37").Interior.Color = RGB(255, 217, 102)
Range("AT1:BA1").Interior.Color = RGB(255, 217, 102)
Range("A46:A53").Interior.Color = RGB(255, 217, 102)
Range("BJ1:BM1").Interior.Color = RGB(255, 217, 102)
Range("A62:A65").Interior.Color = RGB(255, 217, 102)
stname = ActiveSheet.Name
iret = MsgBox("ブック: " & ThisWorkbook.Name & vbCrLf & _
"シート: " & stname & vbCrLf & "3D迷路表示用に初期化してもよろしいですか?" & _
vbCrLf & "(シートのすべてのセル情報がクリアされます)", _
vbYesNo + vbExclamation, "3DマップMacro")
If iret = vbNo Then Exit Sub
'//シートをクリアする
シートクリア stname
'//3Dマップ表示エリア(64×62)を生成
For i = 2 To D_MAPCELL + 1
Cells(1, i) = i - 1
Cells(2 + D_MAPCELL, i) = i - 1
Cells(i, 1) = i - 1
Cells(i, 2 + D_MAPCELL) = i - 1
Next
Range("B1:E1").Interior.Color = RGB(255, 217, 102)
Range("A2:A5").Interior.Color = RGB(255, 217, 102)
Range("N1:U1").Interior.Color = RGB(255, 217, 102)
Range("A14:A21").Interior.Color = RGB(255, 217, 102)
Range("AD1:AK1").Interior.Color = RGB(255, 217, 102)
Range("A30:A37").Interior.Color = RGB(255, 217, 102)
Range("AT1:BA1").Interior.Color = RGB(255, 217, 102)
Range("A46:A53").Interior.Color = RGB(255, 217, 102)
Range("BJ1:BM1").Interior.Color = RGB(255, 217, 102)
Range("A62:A65").Interior.Color = RGB(255, 217, 102)
Range("B" & CStr(D_MAPCELL + 2) & ":E" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN2:BN5").Interior.Color = RGB(255, 217, 102)
Range("N" & CStr(D_MAPCELL + 2) & ":U" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN14:BN21").Interior.Color = RGB(255, 217, 102)
Range("AD" & CStr(D_MAPCELL + 2) & ":AK" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN30:BN37").Interior.Color = RGB(255, 217, 102)
Range("AT" & CStr(D_MAPCELL + 2) & ":BA" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN46:BN53").Interior.Color = RGB(255, 217, 102)
Range("BJ" & CStr(D_MAPCELL + 2) & ":BM" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN62:BN65").Interior.Color = RGB(255, 217, 102)
Range("BN2:BN5").Interior.Color = RGB(255, 217, 102)
Range("N" & CStr(D_MAPCELL + 2) & ":U" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN14:BN21").Interior.Color = RGB(255, 217, 102)
Range("AD" & CStr(D_MAPCELL + 2) & ":AK" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN30:BN37").Interior.Color = RGB(255, 217, 102)
Range("AT" & CStr(D_MAPCELL + 2) & ":BA" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN46:BN53").Interior.Color = RGB(255, 217, 102)
Range("BJ" & CStr(D_MAPCELL + 2) & ":BM" & CStr(C_MAPCELL + 2)).Interior.Color = RGB(255, 217, 102)
Range("BN62:BN65").Interior.Color = RGB(255, 217, 102)
'//外枠罫線をセット
With Range(Cells(2, 2), Cells(D_MAPCELL + 1, D_MAPCELL + 1))
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
End With
'//3D迷路エリアの初期設定
Range("B2:BM8").Interior.Color = RGB(240, 240, 240)
Range("B9:BM14").Interior.Color = RGB(214, 214, 214)
Range("B15:BM19").Interior.Color = RGB(188, 188, 188)
Range("B20:BM23").Interior.Color = RGB(162, 162, 162)
Range("B24:BM26").Interior.Color = RGB(136, 136, 136)
Range("B27:BM28").Interior.Color = RGB(110, 110, 110)
Range("B29:BM29").Interior.Color = RGB(84, 84, 84)
Range("B30:BM37").Interior.Color = RGB(58, 58, 58)
Range("B38:BM65").Interior.Color = RGB(248, 203, 173)
'//セル幅と台形の幅(システムで不変)をセット
SetMapSpanAndTrapezoidalWidth
'//マップ情報(初期表示)を取得
If Not マップデータ取得(0) Then
MsgBox "マップデータの取得に失敗しました", vbOKOnly + vbExclamation, "3DマップMacro"
Exit Sub
End If
'//描画範囲表示
マップガイドエリア初期化
'//3D迷路描画(初期表示)
迷路描画処理
'//サンプル表示用のボタンを追加
Dim cw As Double, ch As Double
'//セル1つの幅と高さ
cw = Range("A1").Width
ch = Range("A1").Height
Dim obj As Object
For Each obj In ActiveSheet.Buttons
If obj.OnAction = "" Then obj.Delete
Next
With ActiveSheet.Buttons.Add(cw * (D_MAPCELL + 9), ch * 45, cw * 10, ch * 5)
.Caption = "次のサンプルマップ"
.Font.Size = 20
.OnAction = "CmdBtn1_Click"
End With
End Sub
With Range(Cells(2, 2), Cells(D_MAPCELL + 1, D_MAPCELL + 1))
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.Color = RGB(0, 0, 0)
End With
End With
'//3D迷路エリアの初期設定
Range("B2:BM8").Interior.Color = RGB(240, 240, 240)
Range("B9:BM14").Interior.Color = RGB(214, 214, 214)
Range("B15:BM19").Interior.Color = RGB(188, 188, 188)
Range("B20:BM23").Interior.Color = RGB(162, 162, 162)
Range("B24:BM26").Interior.Color = RGB(136, 136, 136)
Range("B27:BM28").Interior.Color = RGB(110, 110, 110)
Range("B29:BM29").Interior.Color = RGB(84, 84, 84)
Range("B30:BM37").Interior.Color = RGB(58, 58, 58)
Range("B38:BM65").Interior.Color = RGB(248, 203, 173)
'//セル幅と台形の幅(システムで不変)をセット
SetMapSpanAndTrapezoidalWidth
'//マップ情報(初期表示)を取得
If Not マップデータ取得(0) Then
MsgBox "マップデータの取得に失敗しました", vbOKOnly + vbExclamation, "3DマップMacro"
Exit Sub
End If
'//描画範囲表示
マップガイドエリア初期化
'//3D迷路描画(初期表示)
迷路描画処理
'//サンプル表示用のボタンを追加
Dim cw As Double, ch As Double
'//セル1つの幅と高さ
cw = Range("A1").Width
ch = Range("A1").Height
Dim obj As Object
For Each obj In ActiveSheet.Buttons
If obj.OnAction = "" Then obj.Delete
Next
With ActiveSheet.Buttons.Add(cw * (D_MAPCELL + 9), ch * 45, cw * 10, ch * 5)
.Caption = "次のサンプルマップ"
.Font.Size = 20
.OnAction = "CmdBtn1_Click"
End With
End Sub
'/*********************************************
'/ 迷路描画
'/ マップ情報に従い迷路を描画する
'/*********************************************
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)なら四角形を描画
If map(i, j).info = 9 Then
図形座標取得 i, j, "Rectangle", srect
図形描画 srect
GoTo nextrec
End If
'台形描画
'最後尾(i=0)は台形描画なし
If i = 0 Then GoTo nextrec
'中央より左(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
End If
nextrec:
Next
Next
'/ 迷路描画
'/ マップ情報に従い迷路を描画する
'/*********************************************
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)なら四角形を描画
If map(i, j).info = 9 Then
図形座標取得 i, j, "Rectangle", srect
図形描画 srect
GoTo nextrec
End If
'台形描画
'最後尾(i=0)は台形描画なし
If i = 0 Then GoTo nextrec
'中央より左(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
End If
nextrec:
Next
Next
Error_MapView:
Application.ScreenUpdating = True
End Sub
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) 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) 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
'/ 図形座標取得
'/ 現在位置に描画する四角形の座標を取得
'/ 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) 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) 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:描画座標を格納(中央のとき左右の台形を描画するケースがある)
'/*********************************************
Private Sub 図形描画(ByRef srect() As sctrect)
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
'//四角形と台形で色を少し変える
If srect(i).NW(0) = srect(i).NE(0) Then
.Line.ForeColor.RGB = RGB(197, 90, 17)
.Fill.ForeColor.RGB = RGB(191, 144, 0)
Else
.Line.ForeColor.RGB = RGB(197, 90, 17)
.Fill.ForeColor.RGB = RGB(255, 224, 125)
End If
.Fill.Transparency = 0.3
End With
End With
Next
'/ 図形描画
'/ 四角形の座標を元にオートシェイプを描画
'/ srect:描画座標を格納(中央のとき左右の台形を描画するケースがある)
'/*********************************************
Private Sub 図形描画(ByRef srect() As sctrect)
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
'//四角形と台形で色を少し変える
If srect(i).NW(0) = srect(i).NE(0) Then
.Line.ForeColor.RGB = RGB(197, 90, 17)
.Fill.ForeColor.RGB = RGB(191, 144, 0)
Else
.Line.ForeColor.RGB = RGB(197, 90, 17)
.Fill.ForeColor.RGB = RGB(255, 224, 125)
End If
.Fill.Transparency = 0.3
End With
End With
Next
End Sub
'/*********************************************
'/ マップデータを取得する
'/ マップ情報(9:壁 8:描画範囲外(壁) 7:描画範囲外(通路) 0:通路 1:スタート 2:ゴール)
'/ ※スタート、ゴールは次回対応
'/ mapno:マップ番号
'/*********************************************
Private Function マップデータ取得(ByVal mapno As Integer) As Boolean
Dim i As Integer, j As Integer
Dim wkmap As Variant
Dim wkstr() As String
On Error GoTo Error_Map
マップデータ取得 = False
'//map配列を初期化(map.infoエリアのみ変更)
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
map(i, j).info = 9
Next
Next
'//描画可能範囲は□の位置、■は描画しない範囲となる
'//□□□□□□□□□
'//■□□□□□□□■
'//■□□□□□□□■
'//■■□□□□□■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■■□■■■■
Select Case mapno
Case 0
wkmap = Array( _
"9,0,0,0,9,0,0,0,9", _
"9,9,0,9,9,0,9,0,9", _
"0,0,0,9,0,0,9,9,9", _
"9,9,0,9,0,0,0,0,0", _
"9,9,0,0,0,9,9,9,9", _
"0,0,0,9,0,9,9,9,9", _
"0,9,0,9,0,0,0,0,0", _
"9,9,9,9,1,9,9,9,9")
Case 1
wkmap = Array( _
"0,0,0,9,0,9,0,9,0", _
"0,9,9,9,0,9,0,0,0", _
"0,9,0,0,0,9,0,9,0", _
"0,9,0,9,0,9,9,9,9", _
"0,9,0,9,0,9,9,9,9", _
"0,9,0,9,0,0,0,0,0", _
"9,9,9,9,0,9,9,9,9", _
"0,0,9,9,0,9,0,9,9")
Case 2
wkmap = Array( _
"9,9,9,0,0,0,9,0,0", _
"9,0,0,0,9,9,9,9,0", _
"9,0,9,0,9,9,0,0,0", _
"9,0,9,0,9,9,0,9,9", _
"9,9,9,0,9,9,0,9,0", _
"9,9,0,0,0,0,0,9,9", _
"9,9,9,9,0,9,9,9,9", _
"9,0,0,0,0,0,0,0,0")
Case 3
wkmap = Array( _
"0,9,9,0,9,9,9,0,9", _
"9,9,9,0,9,0,0,0,9", _
"0,0,0,0,9,0,9,0,9", _
"9,9,9,0,9,0,9,0,9", _
"0,0,0,0,9,0,9,0,0", _
"9,9,0,9,9,9,9,0,9", _
"0,9,0,0,0,9,9,0,9", _
"9,9,0,9,0,9,0,0,0")
Case 4
wkmap = Array( _
"9,9,0,9,9,9,9,0,9", _
"9,9,0,9,0,9,9,0,9", _
"9,0,0,0,0,0,0,9,9", _
"9,0,9,9,0,9,9,9,9", _
"0,0,9,9,0,0,0,0,9", _
"9,0,9,9,0,9,9,0,9", _
"9,0,9,9,9,9,9,0,9", _
"0,0,0,0,0,0,0,0,9")
Case Else
Exit Function
End Select
'//マップデータをセット
For i = 0 To UBound(map, 1)
'1行分のデータを取得
wkstr = Split(wkmap(i), ",")
For j = 0 To UBound(map, 2)
'行が可能範囲外なら強制的に描画範囲外=8をセット
'("■"の箇所は強制的に8をセット)
GetMapValue i, j, wkstr(j)
Next
Next
マップデータ取得 = True
Error_Map:
'//サンプル番号を更新
sampleno = mapno
End Function
'/ マップデータを取得する
'/ マップ情報(9:壁 8:描画範囲外(壁) 7:描画範囲外(通路) 0:通路 1:スタート 2:ゴール)
'/ ※スタート、ゴールは次回対応
'/ mapno:マップ番号
'/*********************************************
Private Function マップデータ取得(ByVal mapno As Integer) As Boolean
Dim i As Integer, j As Integer
Dim wkmap As Variant
Dim wkstr() As String
On Error GoTo Error_Map
マップデータ取得 = False
'//map配列を初期化(map.infoエリアのみ変更)
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
map(i, j).info = 9
Next
Next
'//描画可能範囲は□の位置、■は描画しない範囲となる
'//□□□□□□□□□
'//■□□□□□□□■
'//■□□□□□□□■
'//■■□□□□□■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■□□□■■■
'//■■■■□■■■■
Select Case mapno
Case 0
wkmap = Array( _
"9,0,0,0,9,0,0,0,9", _
"9,9,0,9,9,0,9,0,9", _
"0,0,0,9,0,0,9,9,9", _
"9,9,0,9,0,0,0,0,0", _
"9,9,0,0,0,9,9,9,9", _
"0,0,0,9,0,9,9,9,9", _
"0,9,0,9,0,0,0,0,0", _
"9,9,9,9,1,9,9,9,9")
Case 1
wkmap = Array( _
"0,0,0,9,0,9,0,9,0", _
"0,9,9,9,0,9,0,0,0", _
"0,9,0,0,0,9,0,9,0", _
"0,9,0,9,0,9,9,9,9", _
"0,9,0,9,0,9,9,9,9", _
"0,9,0,9,0,0,0,0,0", _
"9,9,9,9,0,9,9,9,9", _
"0,0,9,9,0,9,0,9,9")
Case 2
wkmap = Array( _
"9,9,9,0,0,0,9,0,0", _
"9,0,0,0,9,9,9,9,0", _
"9,0,9,0,9,9,0,0,0", _
"9,0,9,0,9,9,0,9,9", _
"9,9,9,0,9,9,0,9,0", _
"9,9,0,0,0,0,0,9,9", _
"9,9,9,9,0,9,9,9,9", _
"9,0,0,0,0,0,0,0,0")
Case 3
wkmap = Array( _
"0,9,9,0,9,9,9,0,9", _
"9,9,9,0,9,0,0,0,9", _
"0,0,0,0,9,0,9,0,9", _
"9,9,9,0,9,0,9,0,9", _
"0,0,0,0,9,0,9,0,0", _
"9,9,0,9,9,9,9,0,9", _
"0,9,0,0,0,9,9,0,9", _
"9,9,0,9,0,9,0,0,0")
Case 4
wkmap = Array( _
"9,9,0,9,9,9,9,0,9", _
"9,9,0,9,0,9,9,0,9", _
"9,0,0,0,0,0,0,9,9", _
"9,0,9,9,0,9,9,9,9", _
"0,0,9,9,0,0,0,0,9", _
"9,0,9,9,0,9,9,0,9", _
"9,0,9,9,9,9,9,0,9", _
"0,0,0,0,0,0,0,0,9")
Case Else
Exit Function
End Select
'//マップデータをセット
For i = 0 To UBound(map, 1)
'1行分のデータを取得
wkstr = Split(wkmap(i), ",")
For j = 0 To UBound(map, 2)
'行が可能範囲外なら強制的に描画範囲外=8をセット
'("■"の箇所は強制的に8をセット)
GetMapValue i, j, wkstr(j)
Next
Next
マップデータ取得 = True
Error_Map:
'//サンプル番号を更新
sampleno = mapno
End Function
'/*********************************************
'/ マップデータの描画可能範囲を判定してセットする値を返す
'/*********************************************
Private Function GetMapValue( _
ByVal gyo As Integer, ByVal clm As Integer, ByVal val As String) As Integer
Dim wkstr As String
Dim outrng As Boolean
GetMapValue = 9
wkstr = Trim(val)
'//位置が描画可能範囲外のとき
'//元が壁なら強制的に描画範囲外=8をセット
'//元が通路(9以外)なら描画範囲外=7をセット
'//("■"の箇所は強制的に8または7をセット)
outrng = False
If (gyo = 1 Or gyo = 2) And (clm = 0 Or clm = 8) Then
outrng = True
ElseIf gyo = 3 And (clm < 2 Or clm > 6) Then
outrng = True
ElseIf (gyo > 3 And gyo < 7) And (clm < 3 Or clm > 5) Then
outrng = True
ElseIf gyo = 7 And clm <> 4 Then
outrng = True
End If
If outrng = True Then
If wkstr = "9" Then
map(gyo, clm).info = 8
Else
map(gyo, clm).info = 7
End If
Else
map(gyo, clm).info = CInt(wkstr)
End If
End Function
'/ マップデータの描画可能範囲を判定してセットする値を返す
'/*********************************************
Private Function GetMapValue( _
ByVal gyo As Integer, ByVal clm As Integer, ByVal val As String) As Integer
Dim wkstr As String
Dim outrng As Boolean
GetMapValue = 9
wkstr = Trim(val)
'//位置が描画可能範囲外のとき
'//元が壁なら強制的に描画範囲外=8をセット
'//元が通路(9以外)なら描画範囲外=7をセット
'//("■"の箇所は強制的に8または7をセット)
outrng = False
If (gyo = 1 Or gyo = 2) And (clm = 0 Or clm = 8) Then
outrng = True
ElseIf gyo = 3 And (clm < 2 Or clm > 6) Then
outrng = True
ElseIf (gyo > 3 And gyo < 7) And (clm < 3 Or clm > 5) Then
outrng = True
ElseIf gyo = 7 And clm <> 4 Then
outrng = True
End If
If outrng = True Then
If wkstr = "9" Then
map(gyo, clm).info = 8
Else
map(gyo, clm).info = 7
End If
Else
map(gyo, clm).info = CInt(wkstr)
End If
End Function
'/*********************************************
'/ マップガイドエリア初期化
'/ 4セルを1マスとして表示(大きいほうが見やすいため)
'/*********************************************
Private Sub マップガイドエリア初期化()
Dim i As Integer, j As Integer
Dim gyo As Integer, clm As Integer
For i = 0 To UBound(map, 1)
'行描画時の行番号、列番号の初期値
gyo = (i * 2) + 25
clm = D_MAPCELL + 6
For j = 0 To UBound(map, 2)
With Range(Cells(gyo, clm), Cells(gyo + 1, clm + 1))
.Merge
If map(i, j).info = 9 Then
.Interior.Color = RGB(142, 169, 219)
ElseIf map(i, j).info = 8 Then
.Interior.Color = RGB(110, 110, 110)
ElseIf map(i, j).info = 7 Then
.Interior.Color = RGB(162, 162, 162)
Else
.Interior.Color = RGB(255, 255, 255)
End If
.Value = map(i, j).info
'罫線をセット
With .Borders
.LineStyle = xlDash
.Weight = xlThin
.Color = RGB(110, 110, 110)
End With
'最前面の中央には"▲"をセット
If i = 7 And j = 4 Then
.Value = "▲"
.Font.Color = RGB(255, 0, 0)
.Font.Size = 20
.Interior.Color = RGB(255, 255, 255)
End If
End With
clm = clm + 2
Next
Next
End Sub
Next
Next
End Sub
'/*********************************************
'/ シートをクリアする
'/ stname:クリア対象シート名
'/*********************************************
Private Sub シートクリア(ByVal stname As String)
Dim sp As Variant
'//シート選択
ThisWorkbook.Sheets(stname).Activate
'//セルを初期化する
Cells.Select
Selection.UnMerge
Selection.Clear
Selection.ColumnWidth = D_WIDTH
Selection.RowHeight = D_HEIGHT
Selection.Font.Name = "Meiryo UI"
Selection.Font.Size = 8
Selection.Borders.LineStyle = False
'//中央揃えを設定
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
'//セルの折り返しを解除
Selection.WrapText = False
'//オートシェイプを削除する
For Each sp In ActiveSheet.Shapes
sp.Delete
Next
ActiveWindow.Zoom = 40
Range("A1").Select
End Sub
'/ シートをクリアする
'/ stname:クリア対象シート名
'/*********************************************
Private Sub シートクリア(ByVal stname As String)
Dim sp As Variant
'//シート選択
ThisWorkbook.Sheets(stname).Activate
'//セルを初期化する
Cells.Select
Selection.UnMerge
Selection.Clear
Selection.ColumnWidth = D_WIDTH
Selection.RowHeight = D_HEIGHT
Selection.Font.Name = "Meiryo UI"
Selection.Font.Size = 8
Selection.Borders.LineStyle = False
'//中央揃えを設定
Selection.HorizontalAlignment = xlCenter
Selection.VerticalAlignment = xlCenter
'//セルの折り返しを解除
Selection.WrapText = False
'//オートシェイプを削除する
For Each sp In ActiveSheet.Shapes
sp.Delete
Next
ActiveWindow.Zoom = 40
Range("A1").Select
End Sub
'/*********************************************
'/ マップを描画するときのセル幅と
'/ 台形を描画するときの幅を取得
'/ span:セル幅
'/ twidth:台形の幅
'/*********************************************
Private Sub SetMapSpanAndTrapezoidalWidth()
Dim wkspan As Variant, wkwid As Variant
Dim strspan() As String, strwid() As String
Dim i As Integer, j As Integer
'//初期化
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
map(i, j).span = 0
map(i, j).twidth = 0
Next
Next
wkspan = Array( _
"4,8,8,8,8,8,8,8,4", _
"0,9,9,9,10,9,9,9,0", _
"0,3,11,11,14,11,11,3,0", _
"0,0,8,14,20,14,8,0,0", _
"0,0,0,18,28,18,0,0,0", _
"0,0,0,13,38,13,0,0,0", _
"0,0,0,7,50,7,0,0,0", _
"0,0,0,0,64,0,0,0,0")
wkwid = Array( _
"0,0,0,0,0,0,0,0,0", _
"0,4,3,2,1,2,3,4,0", _
"0,0,6,4,2,4,6,0,0", _
"0,0,3,6,3,6,3,0,0", _
"0,0,0,8,4,8,0,0,0", _
"0,0,0,0,5,0,0,0,0", _
"0,0,0,0,6,0,0,0,0", _
"0,0,0,0,7,0,0,0,0")
For i = 0 To UBound(map, 1)
strspan = Split(wkspan(i), ",")
strwid = Split(wkwid(i), ",")
For j = 0 To UBound(map, 2)
map(i, j).span = CInt(strspan(j))
map(i, j).twidth = CInt(strwid(j))
Next
Next
End Sub
'/ マップを描画するときのセル幅と
'/ 台形を描画するときの幅を取得
'/ span:セル幅
'/ twidth:台形の幅
'/*********************************************
Private Sub SetMapSpanAndTrapezoidalWidth()
Dim wkspan As Variant, wkwid As Variant
Dim strspan() As String, strwid() As String
Dim i As Integer, j As Integer
'//初期化
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
map(i, j).span = 0
map(i, j).twidth = 0
Next
Next
wkspan = Array( _
"4,8,8,8,8,8,8,8,4", _
"0,9,9,9,10,9,9,9,0", _
"0,3,11,11,14,11,11,3,0", _
"0,0,8,14,20,14,8,0,0", _
"0,0,0,18,28,18,0,0,0", _
"0,0,0,13,38,13,0,0,0", _
"0,0,0,7,50,7,0,0,0", _
"0,0,0,0,64,0,0,0,0")
wkwid = Array( _
"0,0,0,0,0,0,0,0,0", _
"0,4,3,2,1,2,3,4,0", _
"0,0,6,4,2,4,6,0,0", _
"0,0,3,6,3,6,3,0,0", _
"0,0,0,8,4,8,0,0,0", _
"0,0,0,0,5,0,0,0,0", _
"0,0,0,0,6,0,0,0,0", _
"0,0,0,0,7,0,0,0,0")
For i = 0 To UBound(map, 1)
strspan = Split(wkspan(i), ",")
strwid = Split(wkwid(i), ",")
For j = 0 To UBound(map, 2)
map(i, j).span = CInt(strspan(j))
map(i, j).twidth = CInt(strwid(j))
Next
Next
End Sub
'/*********************************************
'/ コマンドボタンクリックでサンプル表示を切り替え
'/*********************************************
Private Sub CmdBtn1_Click()
'//オートシェイプを削除する
For Each sp In ActiveSheet.Shapes
If sp.Type = msoFormControl Then GoTo nextrec
sp.Delete
nextrec:
Next
'//セル幅と台形の幅(システムで不変)が設定されていなければセット
'//ブックを保存して初期化を実行せずにコマンドボタンを押下した場合を想定
Dim i As Integer, j As Integer
Dim bSetting As Boolean
bSetting = False
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
If map(i, j).span <> 0 Then bSetting = True
If map(i, j).twidth <> 0 Then bSetting = True
If bSetting = True Then GoTo SetSpanAndWidth
Next
Next
SetSpanAndWidth:
If bSetting = False Then SetMapSpanAndTrapezoidalWidth
'//次のサンプルを表示
sampleno = sampleno + 1
If sampleno > 4 Then sampleno = 0
'//マップ情報(初期表示)を取得
If Not マップデータ取得(sampleno) Then
MsgBox "マップデータの取得に失敗しました", vbOKOnly + vbExclamation, "3DマップMacro"
Exit Sub
End If
'//描画範囲表示
マップガイドエリア初期化
'//3D迷路描画(初期表示)
迷路描画処理
End Sub
'/ コマンドボタンクリックでサンプル表示を切り替え
'/*********************************************
Private Sub CmdBtn1_Click()
'//オートシェイプを削除する
For Each sp In ActiveSheet.Shapes
If sp.Type = msoFormControl Then GoTo nextrec
sp.Delete
nextrec:
Next
'//セル幅と台形の幅(システムで不変)が設定されていなければセット
'//ブックを保存して初期化を実行せずにコマンドボタンを押下した場合を想定
Dim i As Integer, j As Integer
Dim bSetting As Boolean
bSetting = False
For i = 0 To UBound(map, 1)
For j = 0 To UBound(map, 2)
If map(i, j).span <> 0 Then bSetting = True
If map(i, j).twidth <> 0 Then bSetting = True
If bSetting = True Then GoTo SetSpanAndWidth
Next
Next
SetSpanAndWidth:
If bSetting = False Then SetMapSpanAndTrapezoidalWidth
'//次のサンプルを表示
sampleno = sampleno + 1
If sampleno > 4 Then sampleno = 0
'//マップ情報(初期表示)を取得
If Not マップデータ取得(sampleno) Then
MsgBox "マップデータの取得に失敗しました", vbOKOnly + vbExclamation, "3DマップMacro"
Exit Sub
End If
'//描画範囲表示
マップガイドエリア初期化
'//3D迷路描画(初期表示)
迷路描画処理
End Sub
よろしければポチッと押してください