【Word VBA】瓢箪模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 瓢箪模様描画マクロ()

    Const GOURLEFT = 100 　　　　'描画開始位置Ｘ

    Const GOURTOPP = 100　　　   '　　　　　　Ｙ

    '

    Const GOURSWID = 35　　       '描画幅

    Const GOURSHEI = 45　　        '描画高さ

    '

    Const GOURMAGI = 0.1 　　　　'ベジェ描画倍率

    Const GOURCOLS = 7 　　　　　'横/描画数

    Const GOURROWS = 4 　　　　 '縦/描画数

    '

    Const GOURLNWE = 1              '線の太さ

    Const GOURSANG = 30             '図の傾き

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, lngCol(1) As Long

    Dim intDxp As Integer, intDyp As Integer

    Dim sngBas(18, 1) As Single, varBez As Variant

    Dim sngDat(18, 1) As Single

    '

    '*ベジェ曲線データ設定

    varBez = Array(0, 220, 13, 223, 21, 215, 19, 192, 73, 165, 71, _

  128, 44, 60, 158, -23, 111, -110, -3, -126, -135, -122, -182, 5, _

  -34, 64, -61, 116, -68, 165, -20, 190, -15, 219, -15, 213, 0, 220)

    '

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

        sngBas(Ip, 0) = CSng(varBez(Ip * 2 + 0)) * GOURMAGI

        sngBas(Ip, 1) = CSng(varBez(Ip * 2 + 1)) * GOURMAGI * -1

    Next Ip

    '

    lngCol(0) = vbBlack                      '←線色

    lngCol(1) = RGB(255, 218, 185)    '←塗りつぶし色

    For Jp = 0 To GOURROWS - 1

        intDyp = GOURTOPP + GOURSHEI * Jp

        For Ip = 0 To GOURCOLS - 1

            intDxp = GOURLEFT + GOURSWID * Ip

            '*ベジエ曲線位置設定

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

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

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

            Next Kp

            '*ベジエ曲線描画

            With ActiveDocument.Shapes.AddCurve(sngDat)

                 .Fill.Visible = msoTrue

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

                 .Line.Visible = msoTrue

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

                 .Line.Weight = GOURLNWE          '←線の太さ

                 .Rotation = GOURSANG               '←図の傾き

           End With

        Next Ip

    Next Jp

End Sub