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

0

    <機能>

    (1)VBAで3D迷路(プチゲーム)を作ってみます

      今回は3Dを表示するところまでです

      サンプルマップを5種類切り替えて表示します

      次回、マップ上を移動できるようにするつもりです(お盆には完成させたい)

    (2)3D迷路に必要な台形描画はオートシェイプを使用します

    (3)3D迷路の仕様

      (3)-1.マップの大きさは64×64セルとします

      (3)-2.正面の壁、横の壁はオートシェイプを使用します

      (3)-3.奥行きは8階層(インデックス0から7とし0が最奥、7が手前です)

    VBA,Macro,game,3D迷路,オートシェイプ,Shape,

        ・最奥は壁9ブロック、手前は壁1ブロック

        ・座標が通路でとなりが壁の時に横壁を表示します(台形を描画)

        ・横壁は中央より左の時は右辺が短い台形、中央より右の時は左辺が短い台形

      (3)-4.描画は奥から順番に行います(結果として見えない壁も描画処理します)

      (3)-5.階層別の壁と台形の表示位置は下図の通りです

     

    VBA,Macro,game,3D迷路,オートシェイプ,Shape,

        ・上の図の赤色分部が台形(横の壁)を描画するときの台形の幅

        ・下図の灰色分部がマップ表示されない部分(見えない部分)

     

    <実行イメージ>

    シート初期化()実行直後

    下の画像を見るとまだまだ横の壁の表示処理が足りない、、、汗

    次回、修正します

    オートシェイプで3D迷路を作ってみる(後編)へ続く)

    VBA,Macro,game,3D迷路,オートシェイプ,Shape,

    [次のサンプルマップ]押下によりサンプルが切り替わります

    VBA,Macro,game,3D迷路,オートシェイプ,Shape,

    VBA,Macro,game,3D迷路,オートシェイプ,Shape,

     

    <動作検証>
    Microsoft Office 2016

     

    <使い方>

    適当なところにソースを貼り付けてください

    シート初期化() を実行すると3D迷路を描画します

    ※アクティブセルの情報を全てクリアしますのでご注意ください

     

    '//セルの幅と高さ
    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 sampleno 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)
        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)
        '//外枠罫線をセット
        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
    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) 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
    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
    '/*********************************************
    '/ マップデータの描画可能範囲を判定してセットする値を返す
    '/*********************************************

    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
    '/*********************************************
    '/ シートをクリアする
    '/ 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
    '/*********************************************
    '/ コマンドボタンクリックでサンプル表示を切り替え
    '/*********************************************

    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

     

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

     



    calendar

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

    profile

    others

    mobile

    qrcode         スマホ表示に戻す