【Word VBA】ミニトマト描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub ミニトマト描画マクロ()

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

    Const MITOTOPP = 90                '　　　　　　Ｙ

    '

    Const MITORADI = 20                'トマトの実の半径

    Const MITOSWID = (MITORADI * 2)          '描画幅

    Const MITOSHEI = (MITORADI * 2)           '描画高さ

    '

    Const MITOHRAD = (MITORADI * 0.7)    'へた位置

    Const MITOHLWD = 10                          'へたの幅

    Const MITOHLHT = 10                           'へたの高さ

    '

    Const MITOERAD = (MITORADI * 0.8)    'てり位置

    Const MITOEFWD = 5                            'てりの幅

    Const MITOEFHT = 10                           'てりの高さ

    Const MITOVSPC = 3                             '横-間隔

    Const MITOHSPC = 3                             '縦-間隔

    Const MITOCOLS = 5                             '横/描画数

    Const MITOROWS = 4                            '縦/描画数

    '

    Const MITOLNWE = 1                            '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim intAng As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp As Integer, intEyp As Integer

    Dim lngCol(4) As Long, sngRnd As Single

    '

    lngCol(0) = vbBlack                               '←線色

    lngCol(1) = RGB(34, 139, 34)                '←へた色

    lngCol(2) = RGB(255, 0, 0)                    '←実の色

    lngCol(3) = RGB(255, 99, 71)                '←〃

    lngCol(4) = RGB(255, 215, 0)                '←〃

    '

    sngRnd = (4 * Atn(1)) / 180

    Randomize '*乱数系列初期化

    For Jp = 0 To MITOROWS - 1

        intDyp = MITOTOPP + (MITOSHEI + MITOHSPC) * Jp

        For Ip = 0 To MITOCOLS - 1

            intDxp = MITOLEFT + (MITOSWID + MITOVSPC) * Ip

            '*トマトの実（円）描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                  intDxp, intDyp, MITOSWID, MITOSHEI)

                 .Fill.Visible = msoTrue

                 .Fill.ForeColor.RGB = _

                      lngCol(2 + ((Jp * MITOCOLS + Ip) Mod 3))

                 .Line.Visible = msoTrue

                 .Line.ForeColor.RGB = lngCol(0)

                 .Line.Weight = MITOLNWE

            End With

            '*トマトのへた（☆）位置設定

            intAng = 60 + CInt(Rnd(1) * 60)

            intExp = MITOHRAD * Cos(sngRnd * intAng) * -1 _

                  + intDxp + MITOSWID / 2

            intEyp = MITOHRAD * Sin(sngRnd * intAng) * -1 _

                  + intDyp + MITOSHEI / 2

            '*トマトのへた（☆）描画

            With ActiveDocument.Shapes.AddShape(msoShape5pointStar, _

                 intExp - MITOHLWD / 2, _

                 intEyp - MITOHLHT / 2, MITOHLWD, MITOHLHT)

                 .Fill.Visible = msoTrue

                 .Fill.ForeColor.RGB = lngCol(1)

                 .Line.Visible = msoTrue

                 .Line.ForeColor.RGB = lngCol(0)

                 .Line.Weight = MITOLNWE

            End With

            '*トマトのテリ（○）位置設定

            intAng = 20

            intExp = MITOHRAD * Cos(sngRnd * intAng) * -1 _

                  + intDxp + MITOSWID / 2

            intEyp = MITOHRAD * Sin(sngRnd * intAng) * -1 _

                  + intDyp + MITOSHEI / 2

            '*トマトのテリ（○）描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                 intExp - MITOEFWD / 2, _

                 intEyp - MITOEFHT / 2, MITOEFWD, MITOEFHT)

                 .Fill.Visible = msoTrue

                 .Fill.ForeColor.RGB = vbWhite

                 .Line.Visible = msoFalse

                 .Rotation = 20

            End With

        Next Ip

    Next Jp

End Sub