【Word VBA】変形三角形模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 変形三角形模様描画マクロ()

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

    Const DFTRTOPP = 90 　　　  '　　　　　　Ｙ

    '

    Const DFTRCOLS = 6             '横/描画数

    Const DFTRROWS = 6           '縦/描画数

    '

    Const DFTRBZMG = 20         '描画サイズ

    Const DFTRWAVE = 0.4 * DFTRBZMG         '変形量

    '

    Const DFTRVPIT = DFTRBZMG * 1.73205   '横/描画間隔

    Const DFTRHPIT = DFTRBZMG * 1.5          '縦/描画間隔

    '

    Const DFTRLNWE = 1#                             '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim lngCol(1) As Long

    Dim sngBBas(9, 1) As Single, sngBDat(9, 1) As Single

    Dim sngRad As Single, sngTemp(1) As Single

    '

    '*三角形のベジェ曲線データ作成

    sngRad = Atn(1) / 45

    '*三角形の頂点の位置

    For Kp = 0 To 3

        sngBBas(Kp * 3, 0) = _

        Cos((120 * Kp - 90) * sngRad) * DFTRBZMG

        sngBBas(Kp * 3, 1) = _

         Sin((120 * Kp - 90) * sngRad) * DFTRBZMG

    Next Kp

    '*三角形の頂点以外の位置

    For Kp = 0 To 2

        sngTemp(0) = (sngBBas(Kp * 3 + 3, 0) _

                   - sngBBas(Kp * 3 + 0, 0)) / 3

        sngTemp(1) = (sngBBas(Kp * 3 + 3, 1) _

                   - sngBBas(Kp * 3 + 0, 1)) / 3

        For Lp = 1 To 2

            sngBBas(Kp * 3 + Lp, 0) = sngBBas(Kp * 3, 0) _

                                   + sngTemp(0) * Lp

           sngBBas(Kp * 3 + Lp, 1) = sngBBas(Kp * 3, 1) _

                                   + sngTemp(1) * Lp

        Next Lp

    Next Kp

   '*三角形を変形するためベジェ曲線データ変更

    sngBBas(1, 0) = sngBBas(1, 0) + DFTRWAVE

    sngBBas(2, 0) = sngBBas(2, 0) - DFTRWAVE

    sngBBas(4, 1) = sngBBas(4, 1) + DFTRWAVE

    sngBBas(5, 1) = sngBBas(5, 1) - DFTRWAVE

    sngBBas(7, 0) = sngBBas(7, 0) - DFTRWAVE

    sngBBas(8, 0) = sngBBas(8, 0) + DFTRWAVE

   '

     lngCol(0) = RGB(0, 0, 128)            '←線色

     lngCol(1) = RGB(255, 20, 147)      '←塗りつぶし

     For Jp = 0 To DFTRROWS - 1

         intDyp = DFTRTOPP + DFTRHPIT * Jp

         For Ip = 0 To DFTRCOLS - 1

             intDxp = DFTRLEFT + DFTRVPIT * Ip _

                    + (DFTRVPIT / 2) * (Jp Mod 2)

            '*三角形（ベジエ曲線）位置設定

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

                sngBDat(Kp, 0) = sngBBas(Kp, 0) + intDxp

                sngBDat(Kp, 1) = sngBBas(Kp, 1) + intDyp

            Next Kp

            '*三角形（ベジエ曲線）描画

            With ActiveDocument.Shapes.AddCurve(sngBDat)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol(1)       '←塗りつぶし

                .Linel.Visible = msoTrue

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

                .Line.Weight = DFTRLNWE

           End With

         Next Ip

     Next Jp

End Sub