【Word VBA】赤とんぼ描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 赤とんぼ描画マクロ()

    Const RDGFLEFT = 90　　　    '描画開始位置Ｘ

    Const RDGFTOPP = 90 　  　　'　　　　　　Ｙ

    '

    Const RDGFVSPC = 70            '描画間隔(横)

    Const RDGFHSPC = 60            '描画間隔(縦）

    Const RDGFCOLS = 4              '横/描画数

    Const RDGFROWS = 3            '縦/描画数

    '

    Const RDGFBZM1 = 0.1          'ベジェ曲線倍率(胴)

    Const RDGFBZM2 = 0.1          'ベジェ曲線倍率(羽）

    Const RDGFWGX1 = -14         '胴と羽の距離Ｘ

    Const RDGFWGX2 = 14

    Const RDGFWGY1 = 15           '胴と羽の距離Ｙ

    Const RDGFWGY2 = 21

    '

    Const RDGFEYX1 = -4            '胴と目玉の距離Ｘ

    Const RDGFEYX2 = 4             '

    Const RDGFEYY1 = -3            '胴と目玉の距離Ｙ

    Const RDGFEYRD = 2.5          '目玉の半径

    '

    Const RDGFANGL = 30 '描画傾き

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim varBz1 As Variant, varBz2 As Variant

    Dim sngBs1(9, 1) As Single, sngBs2(3, 1) As Single

    Dim sngDt1(9, 1) As Single, sngDt2(3, 1) As Single

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp As Integer, intEyp As Integer

    Dim lngCol As Long, varNam(6) As Variant

    '

    'ベジェ曲線データ設定(1=胴体,2=羽)

    varBz1 = Array(0, 260, 70, 240, 10, 130, 25, -60, 25, -300, -25, _

                  -300, -25, -60, -10, 130, -70, 240, 0, 260)

    varBz2 = Array(0, 120, 100, -300, -100, -300, 0, 120)

    '

    For Ip = LBound(sngBs1, 1) To UBound(sngBs1, 1)

        sngBs1(Ip, 0) = (CSng(varBz1(Ip * 2 + 0))) * RDGFBZM1

        sngBs1(Ip, 1) = (CSng(varBz1(Ip * 2 + 1)) - 260) 　_

                             * RDGFBZM1 * -1

    Next Ip

    For Ip = LBound(sngBs2, 1) To UBound(sngBs2, 1)

        sngBs2(Ip, 0) = CSng(varBz2(Ip * 2 + 0)) * RDGFBZM2

        sngBs2(Ip, 1) = CSng(varBz2(Ip * 2 + 1)) * RDGFBZM2

    Next Ip

    '

    lngCol = vbRed                '←塗りつぶし色

    '

    For Jp = 0 To RDGFROWS - 1

        intDyp = RDGFTOPP + RDGFHSPC * Jp

        For Ip = 0 To RDGFCOLS - 1

            intDxp = RDGFLEFT + RDGFVSPC * Ip

            '

            For Lp = LBound(sngBs1, 1) To UBound(sngBs1, 1)

                sngDt1(Lp, 0) = sngBs1(Lp, 0) + intDxp

                sngDt1(Lp, 1) = sngBs1(Lp, 1) + intDyp

            Next Lp

            '*赤とんぼ胴体描画

            With ActiveDocument.Shapes.AddCurve(sngDt1)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol

                .Line.Visible = msoFalse

                 varNam(0) = .Name

            End With

            '

            For Kp = 1 To 4

                intExp = intDxp  _

                          + IIf(Kp = 1 Or Kp = 2, RDGFWGX1, RDGFWGX2)

                intEyp = intDyp  _

                          + IIf(Kp = 1 Or Kp = 3, RDGFWGY1, RDGFWGY2)

                For Lp = LBound(sngBs2, 1) To UBound(sngBs2, 1)

                    sngDt2(Lp, 0) = sngBs2(Lp, 0) + intExp

                    sngDt2(Lp, 1) = sngBs2(Lp, 1) + intEyp

                Next Lp

                '*赤とんぼ羽描画

                With ActiveDocument.Shapes.AddCurve(sngDt2)

                    .Fill.Visible = msoTrue

                    .Fill.ForeColor.RGB = lngCol

                    .Line.Visible = msoFalse

                    .Rotation = IIf(Kp < 3, 90, -90)

                    varNam(Kp) = .Name

               End With

            Next Kp

            '

            For Kp = 1 To 2

                intExp = intDxp + Choose(Kp, RDGFEYX1, RDGFEYX2)

                intEyp = intDyp + RDGFEYY1

                '*赤とんぼ目玉描画

                With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                     intExp - RDGFEYRD, intEyp - RDGFEYRD, _

                     RDGFEYRD * 2, RDGFEYRD * 2)

                    .Fill.Visible = msoTrue

                    .Fill.ForeColor.RGB = lngCol

                    .Line.Visible = msoFalse

                    varNam(4 + Kp) = .Name

                End With

            Next Kp

            '*描画部分をグループ化して、傾ける

  ActiveDocument.Shapes.Range(varNam).Group.Rotation = RDGFANGL

        Next Ip

    Next Jp

End Sub