【Word VBA】花菱模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 花菱模様描画マクロ()

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

    Const FLDITOPP = 90         '　　　　　　Ｙ

    '

    Const FLDICOLS = 5          '横/描画数

    Const FLDIROWS = 3        '縦/描画数

    '

    Const FLDILGRD = 24       '花のサイズ

    Const FLDISMRD = 6        '花びらのサイズ

    Const FLDICNRD = 6        'めしべのサイズ

    Const FLDICNLN = 9        '十字の線の長さ

    '

    Const FLDIVPIT = (FLDILGRD + FLDISMRD) * 2　　　  '横-間隔

    Const FLDIHPIT = FLDIVPIT　　　　　　　                   '縦-間隔

    Const FLDILNWE = 1.5 　 '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp(2) As Integer, intEyp(2) As Integer

    Dim intRln As Integer, lngCol(1) As Long

    '

    intRln = FLDILGRD / 2 - FLDISMRD / Sqr(2)

    lngCol(0) = RGB(220, 20, 60) '塗りつぶし色

    lngCol(1) = vbWhite '線色

    '

    For Jp = 0 To FLDIROWS - 1

        intDyp = FLDITOPP + FLDIHPIT * Jp + FLDIHPIT / 2

        For Ip = 0 To FLDICOLS - 1

            intDxp = FLDILEFT + FLDIVPIT * Ip + FLDIVPIT / 2

            'ひし形（塗りつぶし）描画

            With ActiveDocument.Shapes.AddShape( _

                 msoShapeDiamond, _

                 intDxp - FLDILGRD, intDyp - FLDILGRD, _

                 FLDILGRD * 2, FLDILGRD * 2)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol(0)

                .Line.Visible = msoFalse

            End With

            '*花びら部分描画

            For Kp = 1 To 4

                intExp(0) = intDxp _

                + FLDILGRD * Choose(Kp, 0, 1, 0, -1)

                intEyp(0) = intDyp _

                + FLDILGRD * Choose(Kp, -1, 0, 1, 0)

                intExp(1) = intExp(0) _

                + intRln * Choose(Kp, -1, -1, 1, 1)

                intEyp(1) = intEyp(0) _

                + intRln * Choose(Kp, 1, -1, -1, 1)

                intExp(2) = intExp(0) _

                + intRln * Choose(Kp, 1, -1, -1, 1)

                intEyp(2) = intEyp(0) _

                + intRln * Choose(Kp, 1, 1, -1, -1)

                For Lp = 0 To 2

                    '*円形描画

                    With ActiveDocument.Shapes.AddShape( _

                         msoShapeOval, _

                        intExp(Lp) - FLDISMRD, _

                        intEyp(Lp) - FLDISMRD, _

                        FLDISMRD * 2, FLDISMRD * 2)

                       .Fill.Visible = msoTrue

                       .Fill.ForeColor.RGB = lngCol(0)

                       .Line.Visible = msoFalse

                    End With

                Next Lp

               ''*対角線描画

                With ActiveDocument.Shapes.AddConnector( _

                     msoConnectorStraight, _

                     intDxp, intDyp, _

                     intDxp + (FLDILGRD / 2) * _

                     Choose(Kp, -1, 1, 1, -1), _

                     intDyp + (FLDILGRD / 2) * _

                     Choose(Kp, -1, -1, 1, 1)).Line

                    .Visible = msoTrue

                    .ForeColor.RGB = lngCol(1)

                    .Weight = FLDILNWE

                End With

                '*中心十字線描画

                With ActiveDocument.Shapes.AddConnector( _

                     msoConnectorStraight, _

                     intDxp, intDyp, _

                     intDxp + FLDICNLN * _

                     Choose(Kp, -1, 0, 1, 0), _

                     intDyp + FLDICNLN * _

                     Choose(Kp, 0, -1, 0, 1)).Line

                    .Visible = msoTrue

                    .ForeColor.RGB = lngCol(1)

                    .Weight = FLDILNWE

                End With

            Next Kp

            '*中心部分円形描画

            With ActiveDocument.Shapes.AddShape( _

                 msoShapeOval, _

                 intDxp - FLDICNRD, intDyp - FLDICNRD, _

                 FLDICNRD * 2, FLDICNRD * 2)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol(0)

                .Line.Visible = msoTrue

                .Line.ForeColor.RGB = lngCol(1)

               .Line.Weight = FLDILNWE

           End With

        Next Ip

    Next Jp

End Sub