【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

         

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

         


        【VBA】フォームにControlを動的に配置してクラスでイベントを受け取る

        0

          <機能>

          ・フォームにControlをオーナードローします

           TextBox×20

           OptionButton×60(3個1組でグループ化)

           ConboBox×20

           Label×20

          ・フォームのプロパティをスクロールできるよう設定します

           ScrollBars(スクロールバーの表示)

           ScrollHeight(フォーム全体の高さ)

          ・クラスモジュール、標準モジュールを追加します

          ・クラス(WithEvents)でイベントを受け取ります

           Class1:OptionButtonクリックイベントのコールバック

           Class2:ComboBox選択変更イベントのコールバック

           

          <動作環境>

          Microsoft Office 2016

           

          <実行イメージ>

          フォームInitializeでコントロールを配置

          (テキスト、ラジオ、コンボ、ラベルを20組配置)

          VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,グループ化,
          イベントを受け取りテキストボックスに結果表示します

          VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,
           

          <使い方>

          フォームを追加します(ID:UserForm1)

          VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,ユーザーフォーム追加,
           

          ラジオボタンイベント通知クラスを追加します(Class1)

          コンボボックスイベント通知クラスを追加します(Class2)

          フォーム表示用の標準モジュールを追加します(Module1)

          VBA,Class,WithEvents,Controls,OptionButton,標準モジュール,クラスモジュール,
          ソースを貼り付けます

          ユーザフォーム表示()を実行するとフォームを表示します

           

          Module1

          '/*********************************************

          '/ ユーザフォームを表示する
          '/*********************************************

          Public Sub ユーザフォーム表示()
              UserForm1.Show
          End Sub
           

          UserForm1

          '//フォームの幅
          Private Const D_FWIDTH = 400
          '//フォームの高さ
          Private Const D_FHEIGHT = 500
          '//配置するテキストボックスの幅
          Private Const D_WIDTH = 230
          '//配置するテキストボックスの高さ
          Private Const D_HEIGHT = 100
          '//配置するテキストボックスの間隔
          Private Const D_MARGIN = 10
          '//配置するコントロールグループの数
          Private Const D_CONTROLCNT = 20
          '//イベントを検知するクラス(OptionButton)
          Private cls1(1 To D_CONTROLCNT * 3) As New Class1
          '//イベントを検知するクラス(ComboBox)
          Private cls2(1 To D_CONTROLCNT) As New Class2

           

          '/*********************************************
          '/ フォームの初期化イベント
          '/ 動的にコントロールを配置する
          '/ ※コントロールの種類は
          DeveloperNetwork参照
          '/  テキストボックス
          '/  ラジオボタン(OptionButton)×3(グループ化)
          '/  コンボボックス
          '/  ラベル
          '/*********************************************

          Private Sub UserForm_Initialize()

           

              '//フォームのスクロール(垂直方向)有効
              UserForm1.ScrollBars = fmScrollBarsVertical
              '//フォームのスクロールを含めた高さ
              UserForm1.ScrollHeight = 20 + D_CONTROLCNT * (D_HEIGHT + D_MARGIN)
              '//コントロールを格納する
              Dim tmpOB As Control
              Dim tmpCB As Control
             
              For i = 1 To D_CONTROLCNT
                  '//テキストボックスを追加
                  With UserForm1.Controls.Add("Forms.TextBox.1")
                      .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = 40
                      .Width = D_WIDTH
                      .Height = D_HEIGHT
                      .MultiLine = True
                  End With
                 
                  '//ラジオボタンを追加
                  Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
                  With tmpOB
                      .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = D_WIDTH + 60
                      .Width = 80
                      .Height = 20
                      .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 1)
                      .GroupName = "OB" & CStr(i) '//グループ化する
                      .Value = True
                  End With
                  cls1(((i - 1) * 3) + 1).initClass tmpOB, ((i - 1) * 3) + 1
                 
                  Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
                  With tmpOB
                      .Top = 40 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = D_WIDTH + 60
                      .Width = 80
                      .Height = 20
                      .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 2)
                      .GroupName = "OB" & CStr(i) '//グループ化する
                      .Value = False
                  End With
                  cls1(((i - 1) * 3) + 2).initClass tmpOB, ((i - 1) * 3) + 2
                 
                  Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
                  With tmpOB
                      .Top = 60 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = D_WIDTH + 60
                      .Width = 80
                      .Height = 20
                      .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 3)
                      .GroupName = "OB" & CStr(i) '//グループ化する
                      .Value = False
                  End With
                  cls1(((i - 1) * 3) + 3).initClass tmpOB, ((i - 1) * 3) + 3
                 
                  '//コンボボックスを追加
                  Set tmpCB = UserForm1.Controls.Add("Forms.ComboBox.1")
                  With tmpCB
                      .Top = 80 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = D_WIDTH + 60
                      .Width = 80
                      .Height = 20
                      .List = Array("晴れ", "曇り", "雨")
                      .ListIndex = 0
                  End With
                  cls2(i).initClass tmpCB, i
                 
                  '//ラベルを追加
                  With UserForm1.Controls.Add("Forms.Label.1")
                      .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                      .Left = 5
                      .Width = 30
                      .Height = 20
                      .Caption = "No." + CStr(i)
                  End With
              Next
          End Sub

           

          Class1(OptionButton通知)

          '//イベントを受け取るコントロール

          Private WithEvents OB As MSForms.OptionButton
          '//コントロールのインデックスを格納
          Private idx As Integer
           
          '/*********************************************
          '/ ラジオボタン(OptionButton)をセット
          '/*********************************************

          Public Sub initClass(ByVal o As MSForms.OptionButton, ByVal i As Integer)
              Set OB = o
              idx = i
          End Sub
           
          '/*********************************************
          '/ ラジオボタン(OptionButton)クリックイベント
          '/*********************************************

          Private Sub OB_Click()
              Dim strControl As String
              Dim tmpText As Control
              Dim strText As String
             
              '//ユーザフォームのテキストボックスに出力
              strControl = OB.Name
              '//OptionButton1(idx=1)→TextBox1に出力
              '//OptionButton2(idx=2)→TextBox1に出力
              '//OptionButton3(idx=3)→TextBox1に出力
              '//OptionButtonN(idx=N)→TextBox{(idx-1)÷3の商+1}に出力

              Set tmpText = UserForm1.Controls("TextBox" & CStr(((idx - 1) ¥ 3) + 1))
              If tmpText.Value = "" Then
                  strText = ""
              Else
                  strText = tmpText.Value & vbCrLf
              End If
              strText = strText & "ラジオがクリックされました name=" & strControl
             
              tmpText.Value = strText
          End Sub
           
          Class2(ComboBox通知)
          '//イベントを受け取るコントロール
          Private WithEvents CB As MSForms.ComboBox
          '//コントロールのインデックスを格納
          Private idx As Integer
           
          '/*********************************************
          '/ コンボボックス(ComboBox)をセット
          '/*********************************************

          Public Sub initClass(ByVal c As MSForms.ComboBox, ByVal i As Integer)
              Set CB = c
              idx = i
          End Sub
           
          '/*********************************************
          '/ コンボボックス(ComboBox)選択偏向イベント
          '/*********************************************

          Private Sub CB_Change()
              Dim strControl As String
              Dim tmpText As Control
              Dim strText As String
             
              '//ユーザフォームのテキストボックスに出力
              strControl = CB.Name
              Set tmpText = UserForm1.Controls("TextBox" & CStr(idx))
              If tmpText.Value = "" Then
                  strText = ""
              Else
                  strText = tmpText.Value & vbCrLf
              End If
              strText = strText & "コンボが " & CB.Value & " に変更されました name=" & strControl
             
              tmpText.Value = strText
          End Sub
           
          よろしければポチッと押してください

           


          【VBA】位置を指定してバイナリファイルを読み書きする

          0

            <機能>

            ・テスト用のバイナリファイルを出力します

            ・位置を指定してファイルに書き込みを行います

            (Putステートメント)

            ・Seekで位置を指定してファイルから読み込みを行います

            (Getステートメント)

             

            <動作検証>

            Microsoft Office 2016

             

            <実行イメージ>

            指定位置(1062バイト目/1077バイト)から書き込みを実施

            全角8文字(16バイト)を書き込み

            Putステートメントでバイナリファイル書き込み(VBA)

             

            先頭から37バイト目から全角26文字を読み込み

            Seekで位置指定,Getステートメントでバイナリファイル読み込み(VBA)

             

            <使い方>

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

            バイナリファイルを読み書き() を実行すると処理を開始します

             

            '********************************************
            'ファイルポインタ(位置)を指定してファイルを読み書き
            '********************************************

            Sub バイナリファイルを読み書き()
                Dim strFile As String
                Dim fp As Long, fileLen As Long
                Dim strbuf As String * 26
               
                '//ファイル名を生成
                strFile = ThisWorkbook.Path & "¥binaryTest.dat"
               
                '//テスト用バイナリデータをファイルへ書き込み
                Call TestFileWrite(strFile)
               
                '//バイナリモードでファイルをオープン
                fp = FreeFile
                Open strFile For Binary As #fp
                '//ファイルサイズを取得
                fileLen = LOF(fp)
                '//最後の8文字(16バイト)にデータを書き込み
                '//第2引数には先頭から書き込む場合は1を指定する

                Put #fp, (fileLen - 16) + 1, "さいごの8バイト"
               
                '//読み込み位置にポインタ移動
                Seek #fp, 37
                '//26文字[ABCDEFGHIJKLMNOPQRSTUVWXYZ]読込
                Get #fp, , strbuf
                Debug.Print strbuf
               
                '//ファイルを閉じる
                Close (fp)
                MsgBox "おわりました", vbInformation
            End Sub
            '********************************************
            'バイナリデータをテストファイルに出力
            '********************************************

            Sub TestFileWrite(ByVal strfil As String)
                '//バイナリファイルの1バイト毎の入出力にはByte型を用いる
                Dim strbuf As String * 1024
                Dim i As Integer
                Dim fp As Long
                '//書き込みデータをセット
                strbuf = "abcdefghijklmnopqrstuvwxyz0123456789" & _
                            "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
                            "0123456789月火水木金土日あいうえおかきくけこ"
                '//FreeFile関数で使用可能なファイル番号を割り当て
                fp = FreeFile
                '//ファイルが存在する場合は指定アドレスが上書きされるだけのため
                '//書き込み前にファイルを削除するか中身を一旦クリアする

                Open strfil For Output As #fp
                Close (fp)
                '//ファイルオープン(バイナリ書き込みでオープン、ファイルが存在しない場合は新規作成)
                '//モードに下記のいずれかが指定されていればファイルが存在しない場合、新規作成されます
                '//追加モード(Append)、バイナリモード(Binary)、出力モード(Output)、ランダムアクセスモード(Random)

                Open strfil For Binary Access Write As #fp
                '//ファイルに書き込み(ファイル先頭からの書き込みを明示)
                Put #fp, 1, strbuf
               
                '//ファイルを閉じる
                Close (fp)
            End Sub

             

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


            | 1/6PAGES | >>