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

Option Explicit

Option Base 0

Public Sub 小菊文様描画マクロ()

    Const SCHRLEFT = 120         '描画開始位置　X

    Const SCHRTOPP = 100        '                     Y

    '

    Const SCHRMRAD = 3           '真ん中●半径

    Const SCHRCRAD = 10          '周り●並び半径

    Const SCHRHRAD = 22          '花びら並び半径

    '

    Const SCHRROWS = 4           '描画数(縦)

    Const SCHRCOLS = 5            '描画数(横)

    Const SCHRROLN = 65　　    '縦方向間隔

    Const SCHRCOLN = 65 　　　'横方向間隔

    '

    Const SCHRBZXX = 0.05　　  'ベジェ曲線倍率

    Const SCHRBZYC = -5 　　　  'ベジェ曲線描画位置補正値

    '

    Const SCHRLNWE = 0.75　　  '輪郭線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intPxp As Integer, intPyp As Integer

    Dim lngCol(1) As Long, dblRva As Double

    Dim varBez As Variant, sngBez(6, 1) As Single

    '*ベジェ曲線データ

    varBez = Array(3, 0, -50, 45, -107, 199, 0, 220, 107, 200,  _

                                  56, 43, 3, 0)

    '

    lngCol(0) = vbYellow '←塗りつぶし色

    lngCol(1) = vbBlack '←線色

    dblRva = ((4 * Atn(1)) / 180) * (360 / 12)

    For Jp = 0 To SCHRROWS - 1

        intCyp = SCHRTOPP + SCHRROLN * Jp

        For Ip = 0 To SCHRCOLS - 1 - (Jp Mod 2)

            intCxp = SCHRLEFT + SCHRCOLN * Ip  _

                                         + (SCHRCOLN * (Jp Mod 2)) \ 2

            For Kp = 0 To 11

                If (Kp Mod 2) = 0 Then

                   intPxp = SCHRCRAD * Cos(dblRva * Kp) + intCxp

                   intPyp = SCHRCRAD * Sin(dblRva * Kp) + intCyp

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                     intPxp - SCHRMRAD, intPyp - SCHRMRAD, _

                              SCHRMRAD * 2, SCHRMRAD * 2)

                         .Fill.Visible = True                         '←塗りつぶし有無

                         .Fill.ForeColor = lngCol(0)

                         .Line.Visible = True                       '←線の有無

                         .Line.ForeColor.RGB = lngCol(1)    '←線色

                         .Line.Weight = SCHRLNWE

                    End With

                End If

                intPxp = SCHRHRAD * Cos(dblRva * Kp) + intCxp

                intPyp = SCHRHRAD * Sin(dblRva * Kp) + intCyp

                '花びらをベジェ曲線で描画

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

                    sngBez(Lp, 0) = CSng(varBez(Lp * 2 + 0))  _

                                        * SCHRBZXX + intPxp

                    sngBez(Lp, 1) = CSng(varBez(Lp * 2 + 1))  _

                                        * SCHRBZXX + intPyp + SCHRBZYC

                Next Lp

                '*ベジェ曲線描画

                With ActiveDocument.Shapes.AddCurve(sngBez)

                     .Fill.Visible = True                      '←塗りつぶし有無

                     .Fill.ForeColor.RGB = lngCol(0)

                     .Line.Visible = True                    '←線の有無

                     .Line.ForeColor.RGB = lngCol(1)

                     .Line.Weight = SCHRLNWE

                     .Rotation = 30 * Kp - 90

                End With

            Next Kp

           With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                 intCxp - SCHRMRAD, intCyp - SCHRMRAD, _

                          SCHRMRAD * 2, SCHRMRAD * 2)

                 .Fill.Visible = True                        '←塗りつぶし有無

                 .Fill.ForeColor = lngCol(0)

                 .Line.Visible = True                      '←線の有無

                 .Line.ForeColor.RGB = lngCol(1)    '←線色

                 .Line.Weight = SCHRLNWE

             End With

          Next Ip

    Next Jp

End Sub