【Word VBA】霞文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 霞文様描画マクロ()

    Const HAZELEFT = 80　　　    '描画開始位置Ｘ

    Const HAZETOPP = 90 　　　  '　　　　　　Ｙ

    '

    Const HAZESWD1 = 50           '描画幅1

    Const HAZESWD2 = 12           '描画幅2(連結部分)

    Const HAZESWD3 = 36           '描画幅3

    Const HAZESHT1 = 6              '描画高さ

    Const HAZESHT2 = 5              '描画高さ(連結部分)

    '

    Const HAZESMIS = 0.5            '霞描画位置係数

    Const HAZESCNT = 3              '霞の段数

    '

    Const HAZELNRV = 3              '連結描画補正値

    Const HAZEVSPC = 75            '横-間隔

    Const HAZEHSPC = 40            '縦-間隔

    Const HAZECOLS = 4             '横/描画数

    Const HAZEROWS = 4            '縦/描画数

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp(HAZESCNT) As Integer

    Dim lngCol As Long

    '

    lngCol = RGB(169, 169, 169)            '←塗りつぶし色

    For Jp = 0 To HAZEROWS - 1

        intDyp = HAZETOPP + HAZEHSPC * Jp

        '*霞描画位置設定

        For Ip = 0 To HAZECOLS - IIf((Jp Mod 2) = 0, 1, 2)

            intDxp = HAZELEFT + HAZEVSPC * Ip _

                   + (HAZEVSPC / 2) * (Jp Mod 2)

            intExp(0) = 0: intExp(HAZESCNT) = 0

            For Kp = 1 To HAZESCNT - 1

                intExp(Kp) = intExp(HAZESCNT) _

             + (IIf((Kp Mod 2) = 0, HAZESWD1, HAZESWD3) _

             - HAZESWD2 * 2) * HAZESMIS

             intExp(HAZESCNT) = intExp(HAZESCNT) + intExp(Kp)

            Next Kp

            For Kp = 0 To HAZESCNT - 1

        ' *霞(ＦＣ端子記号)描画

                With ActiveDocument.Shapes.AddShape( _

                     msoShapeFlowchartTerminator, _

                     intDxp + intExp(Kp), _

                     intDyp + (HAZESHT1 + HAZESHT2) * Kp, _

                     IIf((Kp Mod 2) = 0, HAZESWD1, HAZESWD3), _

                     HAZESHT1)

                    .Fill.Visible = msoTrue

                    .Fill.ForeColor.RGB = lngCol

                    .Line.Visible = msoFalse

               End With

        '

               If Kp < HAZESCNT - 1 Then

                  For Lp = 0 To 1

                     '*連結(ＦＣ記憶データ記号)描画

                      With ActiveDocument.Shapes.AddShape( _

                            msoShapeFlowchartStoredData, _

                            intDxp + intExp(Kp + 1) _

                          + HAZESWD2 / 4 + HAZELNRV * Lp, _

                            intDyp + (HAZESHT1 + HAZESHT2) * Kp _

                          + HAZESHT1, _

                            HAZESWD2, HAZESHT2)

                           .Fill.Visible = msoTrue

                           .Fill.ForeColor.RGB = lngCol

                          .Line.Visible = msoFalse

                          If Lp = 0 Then

                            .Flip msoFlipHorizontal

                          End If

                       End With

                  Next Lp

               End If

           Next Kp

        Next Ip

    Next Jp

End Sub