【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

           

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

          【VBA】フォルダ選択ダイアログを表示する

          0

            <機能>

            フォルダ選択ダイアログを表示します。

            下記プロパティを設定します。

            ・初期表示フォルダ

            ・ダイアログタイトル

            ・ボタンのキャプション

             

            <動作検証>
            Microsoft Office 2016

             

            <実行イメージ>

            VBA,フォルダ選択ダイアログイメージ

            VBA,選択フォルダ表示

             

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

            フォルダを選択する() を実行すると処理を開始します

             

            '/********************************************************
            '/* フォルダ選択ダイアログを表示する
            '/* 引数:
            '/*  strDefault 初期表示フォルダ
            '/* 戻り値:
            '/*  選択されたときtrue、キャンセルされたときfalse
            '/*  strSelect  選択されたフォルダパス(参照)
            '/********************************************************

            Function SelectFolder(ByVal strDefault As String, _
                                ByRef strSelect As String) As Boolean
                SelectFolder = False
                strSelect = ""
                
                '//フォルダ選択ダイアログを表示
                With Application.FileDialog(msoFileDialogFolderPicker)
                    '初期表示フォルダ
                    .InitialFileName = strDefault & "¥"
                    'タイトルを指定
                    .Title = "フォルダ選択ダイアログサンプル"
                    'ボタンのキャプションを変更
                    .ButtonName = "選択確定"
                    
                    'フォルダが選択された
                    If .Show = True Then
                        strSelect = .SelectedItems(1)
                        SelectFolder = True
                    Else
                        .Execute
                    End If
                End With
            End Function


            '/********************************************************
            '/* フォルダ選択ダイアログ呼び出しサンプル
            '/********************************************************

            Public Sub フォルダを選択する()
                Dim strSelect As String
                Dim wksel As Variant, wkmsg As String
                
                '//フォルダを選択する
                If Not SelectFolder(ThisWorkbook.Path, strSelect) Then
                    MsgBox "フォルダ選択がキャンセルされました", vbCritical
                    Exit Sub
                End If
                
                '//選択されたフォルダを表示
                MsgBox "選択フォルダ:" & vbCrLf & strSelect, vbInformation
                
            End Sub
             

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

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

             



            | 1/6PAGES | >>

            calendar

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

            profile

            others

            mobile

            qrcode         スマホ表示に戻す