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

Option Explicit

Option Base 0

Public Sub 撫子文様描画マクロ()

   Const PINKLEFT = 120 　　　'描画開始位置 Ｘ

    Const PINKTOPP = 100　　  '　　          　Ｙ

    Const PINKPLMG = 0.3 　　 'ポリライン描画倍率

    '

    Const PINKVSPC = 50         '横-間隔

    Const PINKHSPC = 50         '縦-間隔

    Const PINKCOLS = 5           '横/描画数

    Const PINKROWS = 4          '縦/描画数

    '

    Const PINKLNWT = 1            '線の太さ

    Const PINKRADI = 26.1 + 8   '花びらの中心と

                                                '花の中心距離

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim lngCol As Long, sngRva As Single

    Dim varPly As Variant

    Dim sngBas() As Single, sngDat() As Single

    '

    '*ポリラインベースデータ

    varPly = Array(0#, -26.1, 4.8, -22.1, 7.7, -17.5, _

    11.8, -10.1, 15.5, -3.6, 22.1, 3.1, 25.8, 6.9, 27.9, _

    11.2, 28.4, 13.5, 27.3, 19.2, 25.7, 18.9, 21.4, 15.2, _

    20.4, 21.8, 19.9, 22.2, 14.1, 17.2, 13.5, 24.8, 12.7, _

    25#, 7.6, 19.3, 6.4, 26#, 4#, 27.9, 0.3, 21.2, 0#, 21.2, _

    0#, 21.2, -0.3, 21.2, -4#, 27.9, -6.4, 26#, -7.6, 19.3, _

    -12.7, 25#, -13.5, 24.8, -14.1, 17.2, -19.9, 22.2, -20.4, _

    21.8, -21.4, 15.2, -25.7, 18.9, -27.3, 19.2, -28.4, 13.5, _

    -27.9, 11.2, -25.8, 6.9, -22.1, 3.1, -15.5, -3.6, -11.8, _

    -10.1, -7.7, -17.5, -4.8, -22.1, 0#, -26.1)

    '

    ReDim sngBas((UBound(varPly, 1) - 1) \ 2, 1)

    ReDim sngDat((UBound(varPly, 1) - 1) \ 2, 1)

    For Ip = LBound(varPly, 1) To UBound(varPly, 1) Step 2

        sngBas(Ip \ 2, 0) = CSng(varPly(Ip + 0)) * PINKPLMG * -1

        sngBas(Ip \ 2, 1) = CSng(varPly(Ip + 1)) * PINKPLMG * -1

    Next Ip

'

    sngRva = ((4 * Atn(1)) / 180) * 72

    lngCol = RGB(255, 20, 147) '←花の色

    For Jp = 0 To PINKROWS - 1

        intCyp = PINKTOPP + PINKHSPC * Jp

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

            intCxp = PINKLEFT + PINKVSPC * Ip _

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

            '花びら５枚

            For Kp = 0 To 4

                intDxp = (PINKRADI * PINKPLMG) _

                       * Cos(sngRva * Kp) + intCxp

                intDyp = (PINKRADI * PINKPLMG) _

                       * Sin(sngRva * Kp) + intCyp

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

                   sngDat(Lp, 0) = sngBas(Lp, 0) + intDxp

                   sngDat(Lp, 1) = sngBas(Lp, 1) + intDyp

                Next Lp

                '*花びら(ポリライン)描画

                With ActiveDocument.Shapes.AddPolyline(sngDat)

                     .Fill.Visible = msoTrue

                     .Fill.ForeColor.RGB = IIf((Jp Mod 2) = 0, _

                                           vbWhite, lngCol)

                     .Line.Visible = msoTrue

                     .Line.ForeColor.RGB = IIf((Jp Mod 2) = 0, _

                                          lngCol, vbWhite)

                     .Line.Weight = PINKLNWT

                     .Rotation = 72 * Kp + 90

               End With

            Next Kp

        Next Ip

    Next Jp

End Sub