【Excel VBA】順次流れ図描画マクロ▽ソースコード

Ａ列の文字列を流れ図に挿入

手動で位置移動 　　

　　　処理ボックスのサイズは、行幅、列幅で変えれます。

　　　　　　　　　　　　　　　　　（その際は、再実行要）

Option Explicit

Option Base 0

'

Public Sub 順次流れ図描画マクロ()

    Const FCDLFTCL = 4            '流れ図左端桁番号

    Const FCDTOPRW = 2          '流れ図上端行番号

    Const FCDWIDCL = 2           '流れ図幅桁数　

    Const FCPHEIRW = 2           '流れ図高さ行数(処理)

    Const FCTHEIRW = 1           '流れ図高さ行数(端子）

    '

    Const FCDSPCRW = 2          '流れ図間隔行数

    '

    '挿入テキスト文字格納セル

    Const FCCMTCOL = 1 '桁番号

    Const FCCMTROW = 2 '先頭行番号

    '

    '挿入テキストフォント

    Const FCCFNTNA = "ＭＳ ゴシック"

    Const FCCFNTSZ = 16

    '

    '線の太さ

    Const FCDWLNWT = 1

    '

    Const FCDWLNCL = vbBlack            '線色

    Const FCDWFLCL = vbWhite           '塗りつぶし色

    '---------------------------------------------------------------------------

    Dim Ip As Integer

    Dim sngLft As Single, sngWid As Single

    Dim sngTop As Single, sngHei As Single

    Dim intCRw As Integer, intDRw As Integer

    Dim blnEnd As Boolean, blnEdg As Boolean

    Dim strTex As String

    Dim strNam As String, varNam As Variant

    '

    With ActiveSheet

         '左端位置取得

         sngLft = .Cells(FCDTOPRW, FCDLFTCL).Left

         '描画幅取得

         sngWid = 0:

         For Ip = 0 To FCDWIDCL - 1

             sngWid = sngWid + _

             .Cells(FCDTOPRW, FCDLFTCL + Ip).Width

         Next Ip

         '

         '*端子と処理ボックスを描画

         intDRw = FCDTOPRW: intCRw = FCCMTROW

         blnEnd = False: strNam = ""

         Do While blnEnd = False

            '上端位置取得

            sngTop = .Cells(intDRw, FCDLFTCL).Top

            '

            '端かどうか取得

            blnEdg = IIf(intDRw = FCDTOPRW, True, False)

            If Trim(.Cells(intCRw + 1, FCCMTCOL).Value) _

                   = "" Then blnEdg = True: blnEnd = True

            '描画高さ取得

            sngHei = 0

            For Ip = 0 To _

                IIf(blnEdg, FCTHEIRW, FCPHEIRW) - 1

                sngHei = sngHei + _

                  .Cells(intDRw + Ip, FCDLFTCL).Height

            Next Ip

            '挿入文字取得

            strTex = .Cells(intCRw, FCCMTCOL).Value

            '流れ図、部品描画

            With .Shapes.AddShape( _

             IIf(blnEdg, msoShapeFlowchartTerminator, _

                           msoShapeFlowchartProcess), _

                 sngLft, sngTop, sngWid, sngHei)

                 '塗りつぶし色

                 .Fill.Visible = msoTrue

                 .Fill.ForeColor.RGB = FCDWFLCL

                 '線色

                 .Line.Visible = msoTrue

                 .Line.ForeColor.RGB = FCDWLNCL

                 .Line.Weight = FCDWLNWT

                 '

                 With .TextFrame

                   'テキスト ,フォント

                   With .Characters

                      .Text = strTex

                      .Font.ColorIndex = 0

                      .Font.Name = FCCFNTNA

                      .Font.Size = FCCFNTSZ

                      .Font.Bold = True

                   End With

                   'テキスト位置

                   .HorizontalAlignment = xlHAlignCenter

                   .VerticalAlignment = xlVAlignCenter

                End With

                '描画図形の名前取得-コネクタ接続用

                If strNam <> "" Then strNam = strNam & ","

                strNam = strNam & .Name

            End With

           '

           intCRw = intCRw + 1

           intDRw = intDRw + IIf(blnEdg, FCTHEIRW, FCPHEIRW) + 2

         Loop

         '

         'コネクタ描画

         varNam = Split(strNam, ",")

         For Ip = LBound(varNam, 1) To UBound(varNam, 1) - 1

             With .Shapes.AddConnector _

                  (msoConnectorStraight, 1, 1, 1, 1)

                 .Line.ForeColor.RGB = FCDWLNCL

                 .Line.Weight = FCDWLNWT

                 '

                 .ConnectorFormat.BeginConnect _

                  ActiveSheet.Shapes(CStr(varNam(Ip + 0))), 1

                 .ConnectorFormat.EndConnect _

                  ActiveSheet.Shapes(CStr(varNam(Ip + 1))), 1

                  'コネクタ、再接続

                 .RerouteConnections

            End With

         Next Ip

    End With

End Sub