【VBA】オートシェイプで3D迷路を作ってみる(後編)

0

    <機能>

    (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
    '//マップ格納配列(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
    '//描画する四角形の位置を格納
    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
    Error_MapView:
        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
            End With
        Next
    End Sub
    '/*********************************************
    '/ マップデータを取得する
    '/ マップ情報(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

     

    よろしければポチッと押してください


    calendar

    S M T W T F S
          1
    2345678
    9101112131415
    16171819202122
    23242526272829
    30      
    << September 2018 >>

    profile

    others

    mobile

    qrcode         スマホ表示に戻す