【Word VBA】菊の紋章描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 菊の紋章描画マクロ()

    Const CHRYCXPS = 200                     '菊の中心位置　X

    Const CHRYCYPS = 180                     '                     Y

    Const CHRYCONT = 12                      '花びらの数

    Const CHRYSRAD = 20                      '菊の中心円半径

    Const CHRYLRAD = 80                      '菊の花びら長さ

    '

    Const CHRYLNWE = 2 '線の太さ

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

    Dim Ip As Integer, intAng As Integer, dblRd As Double

    Dim intXp(2) As Integer, intYp(2) As Integer

    Dim lngLCl As Long, intFrd As Integer

    '

    lngLCl = vbBlack　　　　　　　　　     '←線色

    '*中心の小丸描画

    With ActiveDocument.Shapes.AddShape(msoShapeOval, _

         CHRYCXPS - CHRYSRAD, CHRYCYPS - CHRYSRAD, _

                    CHRYSRAD * 2, CHRYSRAD * 2)

         .Fill.Visible = False

         .Line.Visible = True

         .Line.ForeColor.RGB = lngLCl

         .Line.Weight = CHRYLNWE

    End With

    '*花びら描画

    dblRd = (4 * Atn(1)) / 180

    intAng = 360 \ CHRYCONT

    intFrd = CHRYLRAD * Tan(dblRd * (intAng / 2))

    For Ip = 0 To CHRYCONT - 1

        intXp(0) = CHRYSRAD * Cos(dblRd * (intAng * Ip)) + CHRYCXPS

        intYp(0) = CHRYSRAD * Sin(dblRd * (intAng * Ip)) + CHRYCYPS

        intXp(1) = CHRYLRAD * Cos(dblRd * (intAng * Ip)) + CHRYCXPS

        intYp(1) = CHRYLRAD * Sin(dblRd * (intAng * Ip)) + CHRYCYPS

        '*放射状の直線描画

        With ActiveDocument.Shapes.AddLine(intXp(0), intYp(0), _

                            intXp(1), intYp(1)).Line

             .ForeColor.RGB = lngLCl '←線色

             .Weight = CHRYLNWE

        End With

        '

        intXp(2) = CHRYLRAD * Cos(dblRd * (intAng * (Ip + 1)))  _

                     + CHRYCXPS

        intYp(2) = CHRYLRAD * Sin(dblRd * (intAng * (Ip + 1)))   _

                     + CHRYCYPS

        '

        intXp(0) = (intXp(1) + intXp(2)) / 2

        intYp(0) = (intYp(1) + intYp(2)) / 2

        '*外側の円弧描画

        With ActiveDocument.Shapes.AddShape(msoShapeArc, _

             intXp(0) - intFrd, intYp(0) - intFrd, _

                    intFrd * 2, intFrd * 2)

            .Fill.Visible = False

            .Line.Visible = True

            .Line.ForeColor.RGB = lngLCl '←線色

            .Line.Weight = CHRYLNWE

            '円弧角

            .Adjustments(1) = (270 + intAng / 2) + intAng * (Ip + 0)

            .Adjustments(2) = (90 - intAng / 2) + intAng * (Ip + 1)

        End With

   Next Ip

End Sub