【Word VBA】さくら模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub さくら模様描画マクロ()

    Const CHBSBLFT = 100           '描画開始中心位置Ｘ

    Const CHBSBTOP = 100       　'　　　　　　　　Ｙ

    '

    Const CHBSCOLS = 5             '横/描画数

    Const CHBSROWS = 4            '縦/描画数

    '

    Const CHBSVPIT = 50            '横/描画間隔

    Const CHBSHPIT = 40            '縦/描画間隔

    '

    Const CHBSBZM1 = 1.8         '大きな花びら倍率

    Const CHBSBZM2 = 1.2         '小さな花びら

    Const CHBSBSRA = 8            '花びら位置係数 

    Const CHBSLNWE = 1 　　　 '線の太さ

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

    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 sngBBas() As Single, sngBDat() As Single

    Dim varBezi As Variant, sngRva As Single

    Dim sngBRat As Single, intRadi As Integer

    Dim lngCol(1) As Long

    '

    '*ベジェデータ（花びら）

    varBezi = Array(0.08, -3.48, -0.48, -4.52, -0.98, -5.36, _

    -1.48, -6.02, -2.81, -5.48, -3.76, -3.77, -3.36, _

    -0.05, -2.83, 2.7, -1.51, 4.2, 0.09, 4.92, 1.49, 4.2, _

    2.81, 2.7, 3.34, -0.05, 3.74, -3.77, 2.79, -5.48, 1.58, _

    -6.05, 1.03, -5.2, 0.66, -4.61, 0.09, -3.42)

'

    'ベジェデータ設定

    ReDim sngBBas((UBound(varBezi, 1) - 1) \ 2, 1)

    ReDim sngBDat((UBound(varBezi, 1) - 1) \ 2, 1)

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

        sngBBas(Lp, 0) = CSng(varBezi(Lp * 2 + 0))

        sngBBas(Lp, 1) = CSng(varBezi(Lp * 2 + 1))

    Next Lp

    '

    '

    sngRva = (Atn(1) / 45) * 72

    lngCol(0) = vbBlack

    For Jp = 0 To CHBSROWS - 1

        intCyp = CHBSBTOP + CHBSHPIT * Jp

        If (Jp Mod 2) = 0 Then

           sngBRat = CHBSBZM1: lngCol(1) = RGB(255, 192, 203)

        Else

           sngBRat = CHBSBZM2: lngCol(1) = RGB(255, 105, 180)

        End If

        intRadi = CInt(CHBSBSRA * sngBRat)

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

            intCxp = CHBSBLFT + CHBSVPIT * Ip _

                              + CHBSVPIT / 2 * (Jp Mod 2)

            '

            For Kp = 0 To 4

                '*ベジェ曲線（花びら）位置設定

                intDxp = intRadi * Cos(sngRva * Kp) + intCxp

                intDyp = intRadi * Sin(sngRva * Kp) + intCyp

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

                     sngBDat(Lp, 0) = sngBBas(Lp, 0) * sngBRat _

                                    + intDxp

                     sngBDat(Lp, 1) = sngBBas(Lp, 1) * sngBRat _

                                    + intDyp

                Next Lp

                  '*ベジェ曲線（花びら）描画

                With ActiveDocument.Shapes.AddCurve(sngBDat)

                    .Line.Visible = msoCTrue

                    .Fill.Visible = msoCTrue

                    .Line.ForeColor.RGB = lngCol(0)

                    .Fill.ForeColor.RGB = lngCol(1)

                    .Line.Weight = CHBSLNWE

                    .Rotation = 72 * Kp + 90

                End With

           Next Kp

        Next Ip

    Next Jp

End Sub

蛇足

　桜を見ると、良寛和尚の句を思い出す。

「散る桜 残る桜も 散る桜」