【VBA】画像ファイルのサムネイルとハイパーリンクを設定

<機能>

(1)ファイルピッカーで画像ファイルを選択します

(2)シートに画像ファイルのハイパーリンクを設定します

(3)シートの画像ファイルのサムネイルを設定します

 

<実行イメージ>

画像リスト実行イメージ,Hyperlinks,Pictures,ハイパーリンク,VBA,

サムネイルクリック,Hyperlinks,Pictures,ハイパーリンク,VBA,

 

<動作検証>

Microsoft Office 365 バージョン1905(11629.20214)

 

<使い方>

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

画像をシートに並べて表示する() を実行します

 

 

'/********************************************************
'/* 画像をシートに並べてハイパーリンクを設定する
'/* 1.画像ファイル(.jpg)を選択する(複数選択可)
'/* 2.画像ファイルのサムネイルをシートに並べる
'/* 3.画像ファイルへのハイパーリンクをシートに設定する
'/********************************************************

Public Sub 画像をシートに並べて表示する()
    On Error GoTo ErrorOccurred

    Dim gazoFiles() As String
    Dim iret As Integer, i As Integer
    Dim stcol As Integer, strow As Integer
    Dim filename As String

    '//ファイル選択ダイアログで画像ファイルを選択する
    With Application.FileDialog(msoFileDialogFilePicker)
        '選択可能ファイル(.jpg)設定
        .Filters.Add "画像ファイル(Jpeg)", "*.jpg"
        '複数ファイル選択可能
        .AllowMultiSelect = True

        'ファイルピッカー表示
        If .Show = False Then
            Exit Sub
        Else
            'SelectedItemsはインデックス1から開始するのでFor文で実装する際は注意
            i = 0
            For Each tmpstr In .SelectedItems
                ReDim Preserve gazoFiles(i)
                gazoFiles(i) = tmpstr
                i = i + 1
            Next
        End If
    End With

    '//シートを初期化していいか確認メッセージを表示する
    iret = MsgBox(ActiveSheet.Name & " : シートを初期化してもよろしいですか?", _
        vbYesNo + vbQuestion, "画像をシートに並べて表示する")
    If iret = vbNo Then Exit Sub

    '//シートを初期化する
    シートクリア ActiveSheet.Name

    '//画像のサムネイルとハイパーリンクを設定
    i = 1
    stcol = 2
    strow = 2
    For Each tmpstr In gazoFiles
        'ハイパーリンクを設定
        '詳細はOfficeデベロッパーセンター参照
        filename = Mid(tmpstr, InStrRev(tmpstr, "¥") + 1)
        Range(Cells(strow, stcol), Cells(strow, stcol)).Select
        ActiveSheet.Hyperlinks.Add _
                Anchor:=ActiveSheet.Range(Cells(strow, stcol), Cells(strow, stcol)), _
                Address:=tmpstr, _
                ScreenTip:=tmpstr, _
                TextToDisplay:=filename

        'サムネイル画像を設定
        Range(Cells(strow + 1, stcol), Cells(strow + 1, stcol)).Select
        ActiveSheet.Pictures.Insert(tmpstr).Select
        Selection.ShapeRange.Height = 150

        '次の開始位置を算出(横方向は最大4画像とする)
        If (i Mod 4) = 0 Then
            stcol = 2
            strow = strow + 12
        Else
            stcol = stcol + 13
        End If
        '次の画像はi番目
        i = i + 1
    Next

    Range("A1").Select
    Exit Sub

ErrorOccurred:
    MsgBox "何かエラーが発生しました", vbCritical
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 = 3
    Selection.RowHeight = 17
    Selection.Font.Name = "Meiryo UI"
    Selection.Font.Size = 12
    Selection.Borders.LineStyle = False
    '//中央揃えを設定
    Selection.HorizontalAlignment = xlLeft
    Selection.VerticalAlignment = xlCenter
    '//セルの折り返しを解除
    Selection.WrapText = False

    '//オートシェイプを削除する
    For Each sp In ActiveSheet.Shapes
        sp.Delete
    Next

    ActiveWindow.Zoom = 80
    Range("A1").Select
End Sub
 

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


プログラマー ブログランキングへ

 


【VBA】FSOでファイル情報出力/バイナリから指定サイズ切り出す

0

    <機能>

    (1)FileSystemObjectのGetFileメソッドでファイル情報を取得する

    (2)Openステートメントでバイナリファイルの指定位置から指定サイズだけ切り出す

     

    <イメージ>

    ファイル情報を出力します

    バイナリファイルの指定位置から指定サイズ分取得して別ファイルに切り出します

    ※サンプルでは50000バイト目から10000バイト分を切り出します

     

    <動作検証&開発環境>
    Microsoft Office 2016

     

    <使い方>

    (1)参照設定を行います
    [Alt]+[F11]でVBE(VBAエディター)を表示します
    メニューの[ツール(T)]から[参照設定(R)]を選択します
    Microsoft Scripting Runtimeをチェックして[OK]を押下してください

     

    (2)標準モジュールを追加します

    (3)ソースを貼り付けます

     

    '********************************************
    'ファイル情報を表示する
    'GetFileの詳細は
    DeveloperNetwork参照
    '********************************************

    Public Sub ファイル情報を表示する()
        On Error GoTo lblerror
        Dim filename As String
        Dim myfso As FileSystemObject, myinfo As Object
        Dim sret As String

        '//テストファイルパス
        filename = ThisWorkbook.Path + "¥testpicture.jpg"
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")

        '//ファイル情報を取得する
        Set myinfo = myfso.GetFile(filename)
        sret = "【File】" + vbCrLf
        '//パス
        sret = sret + myinfo.Path + vbCrLf
        '//ファイル名
        sret = sret + myinfo.Name + vbCrLf
        '//ファイルサイズ
        sret = sret + CStr(myinfo.size) + "バイト" + vbCrLf
        '//ファイルタイプ
        sret = sret + myinfo.Type + vbCrLf
        '//ファイル作成日時・最終アクセス日時・最終更新日時
        sret = sret + "作成日時    :" + DateFormat(myinfo.DateCreated) + vbCrLf
        sret = sret + "最終アクセス日時:" + DateFormat(myinfo.DateLastAccessed) + vbCrLf
        sret = sret + "最終更新日時  :" + DateFormat(myinfo.DateLastModified) + vbCrLf
        '//フォルダ作成日時・最終アクセス日時・最終更新日時
        sret = sret + "【Folder】" + vbCrLf
        sret = sret + "作成日時    :" + DateFormat(myinfo.ParentFolder.DateCreated) + vbCrLf
        sret = sret + "最終アクセス日時:" + DateFormat(myinfo.ParentFolder.DateLastAccessed) + vbCrLf
        sret = sret + "最終更新日時  :" + DateFormat(myinfo.ParentFolder.DateLastModified) + vbCrLf

        MsgBox sret, vbInformation
    lblerror:
        Set myinfo = Nothing
        Set myfso = Nothing
    End Sub

     

    '********************************************
    'Date型の書式を設定する
    '********************************************

    Private Function DateFormat(ByVal dt As Date) As String
        DateFormat = Format(dt, "yyyy-mm-dd hh:nn:ss")
    End Function

     

    '********************************************
    '指定位置から指定サイズ切り出して保存する
    '********************************************

    Public Sub バイナリファイルから指定サイズ切り出す()
        On Error GoTo lblerror
        Dim readfile As String, writefile As String
        Dim rfl As Long, lidx As Long, wfl As Long

        '//切り出す開始位置とサイズ
        '//アドレス0xC350(50000)から10000バイト切り出す
        Dim myichi As Long
        myichi = 0
        Dim mysize As Long
        mysize = 2910731

        '//ファイル指定
        readfile = ThisWorkbook.Path + "¥testpicture.jpg"
        writefile = ThisWorkbook.Path + "¥testbinary.bin"

        '//バッファ
        Dim rbuf() As Byte
        Dim wbuf() As Byte

        '//ファイルを開く
        rfl = FreeFile
        Open readfile For Binary Access Read As rfl
        '//書き込みファイルが存在する場合は中身をいったんクリアする
        wfl = FreeFile
        If Dir(writefile) <> "" Then
            Open writefile For Output As wfl
            Close (wfl)
        End If
        Open writefile For Binary Access Write As wfl
        '//読み込み
        ReDim rbuf(LOF(rfl))
        Get rfl, , rbuf

        '//書き込み
        ReDim wbuf(mysize)
        For lidx = 0 To LOF(rfl) - 1
            If lidx < myichi Then GoTo nextbyte
            If lidx > (myichi + mysize - 1) Then Exit For

            Put wfl, , rbuf(lidx)
    nextbyte:
        Next
        
        Close rfl
        Close wfl
        Exit Sub

    lblerror:
        MsgBox "何かエラーが発生しました", vbCritical
    End Sub

     

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


    プログラマー ブログランキングへ


    【VBA】FSOを使用してファイルの読み・書き・追記を行う

    0

      <機能>

      FSO(FileSystemObject)を使ってファイルの読み・書き・追記を行うサンプルです

      (1)ファイルにテキストを書き込む

      (2)ファイルにテキストを追記する

      (3)ファイルからテキストを読み込む

      (4)フォルダを作成する

      (5)ファイルを別フォルダにリネームしてコピーする

      (6)ファイルをワイルドカードを使用して別フォルダにコピーする

      (7)ファイルを削除する

       

      <実行イメージ>

      上記(1)〜()実行後のイメージです

      ()()  ファイル書き込み・追記を行います

      (3)  追記を行ったファイルを読み込み結果をシートに出力します

      ()()  フォルダを作成し作成したファイルを100回コピーします

      ()  100回コピーされたファイルを別フォルダにワイルドカードを使用してコピーします

      (7)  コピーしたファイルからファイル末尾に不可した数値が10の倍数のファイルを削除します

      VBA,FSO,実行イメージ,

      VBA,FSO,読み込みデータをシートに表示,

       

      <動作検証&開発環境>
      Microsoft Office 2016

       

      <使い方>

      (1)参照設定を行います

      [Alt]+[F11]でVBE(VBAエディター)を表示します

      メニューの[ツール(T)]から[参照設定(R)]を選択します

      Microsoft Scripting Runtimeをチェックして[OK]を押下してください

      VBA,FSO,参照設定,MicrosoftScriptingRuntime,

      これによりForReading / TristateFalseなどの定数が使用できるようになります

       

      (2)標準モジュールを追加してソースを貼り付けます

      (3)「FSOでファイルを操作する」 プロシージャを実行します

       

      Option Explicit
      '/*********************************************
      '/ ファイル操作メイン処理
      '/ このプロシージャをコールする
      '/*********************************************

      Public Sub FSOでファイルを操作する()
          Dim strfile As String
          Dim strfolder As String, strfolder2 As String
          Dim strtxt As String, strbuf() As String
          Dim i As Integer
         
          '//データは横浜市の区ごとの総人口と男女別人口
          strtxt = "横浜市全体,3724844,1855985,1868859" & vbCrLf & _
                  "鶴見区,285356,147650,137706" & vbCrLf & _
                  "神奈川区,238966,121769,117197" & vbCrLf & _
                  "西区,98532,49850,48682" & vbCrLf & _
                  "中区,148312,78087,70225" & vbCrLf & _
                  "南区,194827,97006,97821" & vbCrLf & _
                  "保土ヶ谷区,205493,102381,103112" & vbCrLf & _
                  "磯子区,166229,81827,84402" & vbCrLf & _
                  "金沢区,202229,99167,103062" & vbCrLf & _
                  "港北区,344172,174460,169712" & vbCrLf & _
                  "戸塚区,275283,135271,140012" & vbCrLf & _
                  "港南区,215736,106126,109610" & vbCrLf & _
                  "旭区,247144,120168,126976" & vbCrLf & _
                  "緑区,180366,89002,91364" & vbCrLf & _
                  "瀬谷区,124560,60889,63671" & vbCrLf & _
                  "栄区,122171,59729,62442" & vbCrLf & _
                  "泉区,154025,75460,78565" & vbCrLf & _
                  "青葉区,309692,151182,158510" & vbCrLf & _
                  "都筑区,211751,105961,105790" & vbCrLf
          '//ファイルパス
          strfile = ThisWorkbook.Path & "¥fsotest.txt"
         
          '//――――――――――――――――――――――
          '//(1)ファイルにテキストを書き込む
          If Not WriteUsingFSO(strtxt, strfile) Then
              MsgBox "ファイル書き込み(WriteUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
         
          '//――――――――――――――――――――――
          '//(2)ファイルにテキストを追記する
          If Not AppendUsingFSO(strtxt, strfile) Then
              MsgBox "ファイルへの追記(AppendUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
             
          '//――――――――――――――――――――――
          '//(3)ファイルからテキストを読み込む
          If Not ReadUsingFSO(strbuf, strfile) Then
              MsgBox "ファイル読み込み(ReadUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
          '//結果表示
          For i = 0 To UBound(strbuf)
              'セル内折り返しを解除
              Range("A" & CStr(i + 1)).WrapText = False
              '読み込みデータを出力
              Range("A" & CStr(i + 1)).Value = strbuf(i)
          Next
         
          '//――――――――――――――――――――――
          '//(4)フォルダを作成する
          strfolder = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
          If Not CreateDirUsingFSO(strfolder) Then
              MsgBox "フォルダ作成(CreateDirUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
          '//――――――――――――――――――――――
          '//(5)ファイルを別フォルダにリネームしてコピー
          If Not CopyFileUsingFSO(strfile, strfolder) Then
              MsgBox "ファイルコピー(CopyFileUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
         
          '//――――――――――――――――――――――
          '//(6)ファイルをワイルドカードを使用して別フォルダにコピー
          '//先に移動先フォルダを作成する(フォルダ名が重複しないように1秒Wait)
          Application.Wait Now + TimeValue("0:00:01")
          strfolder2 = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
          If Not CreateDirUsingFSO(strfolder2) Then
              MsgBox "フォルダ作成(CreateDirUsingFSO2)に失敗しました", vbCritical
              Exit Sub
          End If
          '//strfolderに含まれるすべての".txt"ファイルをstrfolder2にコピーする
          If Not CopyFileUsingFSO2(strfolder, strfolder2) Then
              MsgBox "ファイルコピー(CopyFileUsingFSO2)に失敗しました", vbCritical
              Exit Sub
          End If
         
          '//――――――――――――――――――――――
          '//(7)ファイルを削除する
          '//strfolder2から指定ファイルを削除する
          If Not DeleteFileUsingFSO(strfolder2) Then
              MsgBox "ファイル削除(DeleteFileUsingFSO)に失敗しました", vbCritical
              Exit Sub
          End If
         
      End Sub
      '/*********************************************
      '/ ファイル書き込み(FSOでテキストファイルに書き込み)
      '/  stxt : 書き込みテキスト
      '/  sfil : 書き込みファイル
      '/*********************************************

      Private Function WriteUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object, writefso As Object
         
          '//初期値Falseを設定
          WriteUsingFSO = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
          '//TextStreamオブジェクトを[上書き]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
          Set writefso = myfso.CreateTextFile(sfil, True, False)
          '//引数は省略可能なので以下でもよい
          '//Set writefso = myfso.CreateTextFile(sfil)
         
          '//ファイルがなければ作成、あれば上書きとなる
          writefso.Write stxt
          '//TextStreamオブジェクトを閉じる
          writefso.Close
          WriteUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
      '/*********************************************
      '/ ファイルへ追記(FSOでテキストファイルに追記する)
      '/  stxt : 追記するテキスト
      '/  sfil : 追記ファイル
      '/*********************************************

      Private Function AppendUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object, appendfso As Object
         
          '//初期値Falseを設定
          AppendUsingFSO = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
          '//TextStreamオブジェクトを[ファイルの最後に追記]・[ファイルを作成しない]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
          Set appendfso = myfso.OpenTextFile(sfil, ForAppending, False, TristateFalse)
         
          '//ファイルの最後に追記する
          appendfso.Write stxt
          '//TextStreamオブジェクトを閉じる
          appendfso.Close
          AppendUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
      '/*********************************************
      '/ ファイル読み込み(FSOでテキストファイルから読み込み)
      '/  sbuf : 読み込みテキスト(参照渡し)
      '/  sfil : 読み込みファイル
      '/*********************************************

      Private Function ReadUsingFSO(ByRef sbuf() As String, ByVal sfil As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object, readfso As Object
          Dim strwk As String
         
          '//初期値Falseを設定
          ReadUsingFSO = False
          ReDim sbuf(0)
          sbuf(0) = ""
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
          '//TextStreamオブジェクトを[読み取り専用]・[ファイルを作成しない]・[ASCIIファイルとして開く]で作成(詳細はDeveloperNetwork参照)
          Set readfso = myfso.OpenTextFile(sfil, ForReading, False, TristateFalse)
          '//引数は省略可能なので以下でもよい
          '//Set readfso = myfso.OpenTextFile(sfil,ForReading)
         
          '//TextStreamファイル全体を読み込む(改行コードが読み込めない)
          '//sbuf = readfso.ReadAll
          '//TextStreamファイルを1行ずつ読み込む
          Do While readfso.AtEndOfStream <> True
              strwk = readfso.ReadLine
              If sbuf(UBound(sbuf)) <> "" Then
                  ReDim Preserve sbuf(UBound(sbuf) + 1)
                  sbuf(UBound(sbuf)) = ""
              End If
              sbuf(UBound(sbuf)) = strwk
          Loop
         
          '//TextStreamオブジェクトを閉じる
          readfso.Close
          ReadUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
         
      '/*********************************************
      '/ フォルダ作成(FSOでフォルダを作成)
      '/  sfol : 作成フォルダパス
      '/*********************************************

      Private Function CreateDirUsingFSO(ByVal sfol As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object
         
          '//初期値Falseを設定
          CreateDirUsingFSO = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
          '//フォルダの存在チェック
          If myfso.FolderExists(sfol) Then GoTo LblError
         
          '//フォルダを作成する
          myfso.CreateFolder sfol
          CreateDirUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
      '/*********************************************
      '/ ファイルコピー(FSOでファイルをリネームしてコピー)
      '/  sfil : コピー元ファイル
      '/  sfol : コピー先フォルダ
      '/*********************************************

      Private Function CopyFileUsingFSO(ByVal sfil As String, ByVal sfol As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object
          Dim newfil As String, i As Integer
          Dim strtmp As String
         
          '//初期値Falseを設定
          CopyFileUsingFSO = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
         
          '//サンプルとして100回コピーする
          strtmp = Right(sfil, Len(sfil) - InStrRev(sfil, "¥"))
          For i = 1 To 100
             
              newfil = sfol & "¥" & Left(strtmp, InStrRev(strtmp, ".") - 1) & "_" & Format(CStr(i), "000") & ".txt"
              'ファイルを指定フォルダにリネームしてコピー
              '[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー(詳細はDeveloperNetwork参照)
              myfso.CopyFile sfil, newfil, True
          Next
          CopyFileUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
      '/*********************************************
      '/ ファイルコピー(FSOでワイルドカードを使用してファイルを一括コピー)
      '/ ワイルドカードが使用できるのはファイル名のみです
      '/  sfol1 : コピー元ファイル
      '/  sfol2 : コピー先フォルダ
      '/*********************************************

      Private Function CopyFileUsingFSO2(ByVal sfol1 As String, ByVal sfol2 As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object
         
          '//初期値Falseを設定
          CopyFileUsingFSO2 = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
         
          '//[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー
          '//対象は拡張子が".txt"のファイル
          myfso.CopyFile sfol1 & "¥*.txt", sfol2 & "¥", True
          '//ファイルを移動する場合はMoveFileを使用する
          '//myfso.MoveFile sfol1 & "¥*.txt", sfol2 & "¥"
          CopyFileUsingFSO2 = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function
      '/*********************************************
      '/ ファイル削除(FSOで指定ファイルを削除)
      '/ サンプルとしてファイル名末尾の3桁の数値が10の倍数のファイルを削除
      '/  sfol : ファイル格納フォルダ
      '/*********************************************

      Private Function DeleteFileUsingFSO(ByVal sfol As String) As Boolean
          On Error GoTo LblError
          Dim myfso As Object
          Dim strbuf As String, strtmp As String
         
          '//初期値Falseを設定
          DeleteFileUsingFSO = False
         
          '//FSOオブジェクトを取得する
          Set myfso = CreateObject("Scripting.FileSystemObject")
          '//フォルダ内のファイルを取得して対象なら削除する
          strbuf = Dir(sfol & "¥*.txt", vbNormal)
          Do While strbuf <> ""
              'ファイル末尾の3桁の数値を取得
              strtmp = Replace(Right(strbuf, Len(strbuf) - InStrRev(strbuf, "_")), ".txt", "")
              '10の倍数か判定
              If IsNumeric(strtmp) = False Then GoTo LblNextRecord
              If (CInt(strtmp) Mod 10) = 0 Then
                  'ファイルを削除(読み取り専用属性ファイルを削除)(詳細はDeveloperNetwork参照)
                  myfso.DeleteFile sfol & "¥" & strbuf, True
              End If
             
      LblNextRecord:
              strbuf = Dir()
          Loop
         
          '//フォルダを作成する
          DeleteFileUsingFSO = True
          Exit Function
         
      LblError:
          '//Falseで戻る
      End Function

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

      【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

         

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

        【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

           

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

           



          | 1/7PAGES | >>

          selected entries

          categories

          calendar

          S M T W T F S
           123456
          78910111213
          14151617181920
          21222324252627
          28293031   
          << July 2019 >>

          profile

          others

          archives