【Word VBA】 オバケかぼちゃ描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub オバケかぼちゃ描画マクロ()

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

    Const PUMPTOPP = 100 　　　　  '　　　　　　Ｙ

    Const PUMPVSPC = 40                 '横-間隔

    Const PUMPHSPC = 40                 '縦-間隔

    '

    Const PUMPCOLS = 5                  '横/描画数

    Const PUMPROWS = 4                 '縦/描画数

    Const PUMPEYSZ = 6                   '目のサイズ

    Const PUMPEYVP = 5                   '目の位置(外形中心より)

    Const PUMPEYHP = -2.5

    '

    Const PUMPNSWD = 4                 '鼻のサイズ

    Const PUMPNSHT = 5

    Const PUMPNSVP = 0                  '鼻の位置(外形中心より)

    Const PUMPNSHP = 0

    '

    Const PUMPMTVP = 0                  '口の位置(外形中心より)

    Const PUMPMTHP = 12

    '

    Const PUMPHTVP = 0                  'へたの位置(外形中心より)

    Const PUMPHTHP = -17

    '

    Const PUMPBZMG = 0.8              'ベジェ曲線倍率

    '                                               '↓ポリライン〃

    Const PUMPP1MG = (PUMPBZMG * 2)

    Const PUMPP2MG = (PUMPBZMG * 2.5)

    Const PUNPLNWT = 1

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim lngCol(2) As Long

    Dim varBez As Variant, varPL1 As Variant

    Dim varPL2 As Variant

    Dim sngBBs(15, 1) As Single, sngBDt(15, 1) As Single

    Dim sngP1B(17, 1) As Single, sngP1D(17, 1) As Single

    Dim sngP2B(8, 1) As Single, sngP2D(8, 1) As Single

   '

   '*かぼちゃ外形ベジェデータ

    varBez = Array(0#, 18.7, 16.5, 18.2, 20.2, 13.7, 20.9, 0.3, _

    20.3, -12.3, 12#, -13.4, 7.7, -8.4, 6.2, -13.8, -9.1, -14.6, _

    -10.2, -8.9, -16.8, -14.5, -21.2, -11.1, -21.1, 0.2, -20.8, _

    13.7, -16.5, 16.7, -0.1, 18.7)

    '*口のポリラインデータ

    varPL1 = Array(-5#, 3#, -3#, 3#, -3#, 1#, -1#, 1#, -1#, 3#, _

    1#, 3#, 1#, 1#, 3#, 1#, 3#, 3#, 5#, 3#, 5#, -3#, 4#, -3#, 2#, _

    -3#, 2#, -1#, 0#, -1#, 0#, -3#, -5#, -3#, -5#, 3#)

    '*へたのポリラインデータ

    varPL2 = Array(-0.6, -0.4, 0.6, -0.8, 0.3, 2#, 1.4, 2.2, 1.9, _

     2.8, -0.9, 3.4, -1.7, 2.6, -0.5, 2#, -0.6, -0.4)

    '*データ設定

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

        sngBBs(Kp, 0) = CSng(varBez(Kp * 2 + 0)) * PUMPBZMG

        sngBBs(Kp, 1) = CSng(varBez(Kp * 2 + 1)) * PUMPBZMG

    Next Kp

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

        sngP1B(Kp, 0) = CSng(varPL1(Kp * 2 + 0)) * PUMPP1MG

        sngP1B(Kp, 1) = CSng(varPL1(Kp * 2 + 1)) * PUMPP1MG * -0.5

    Next Kp

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

        sngP2B(Kp, 0) = CSng(varPL2(Kp * 2 + 0)) * PUMPP2MG

        sngP2B(Kp, 1) = CSng(varPL2(Kp * 2 + 1)) * PUMPP2MG

    Next Kp

    '

    lngCol(0) = vbBlack                     '←輪郭、穴の色

    lngCol(1) = RGB(255, 165, 0)       '←かぼちゃの色

    lngCol(2) = RGB(0, 100, 0)          '←へたの色

    '

    For Jp = 0 To PUMPROWS - 1

        intDyp = PUMPTOPP + PUMPHSPC * Jp

        For Ip = 0 To PUMPCOLS - 1

            intDxp = PUMPLEFT + PUMPVSPC * Ip

            '*外形描画位置設定

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

                sngBDt(Kp, 0) = sngBBs(Kp, 0) + intDxp

                sngBDt(Kp, 1) = sngBBs(Kp, 1) + intDyp

            Next Kp

            '*外形（ベジェ曲線）描画

            With ActiveDocument.Shapes.AddCurve(sngBDt)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol(1)

                .Line.Visible = msoTrue

                .Line.ForeColor.RGB = lngCol(0)

                .Line.Weight = PUNPLNWT

            End With

            '*目（二等辺三角形）描画

            For Kp = 0 To 1 '左/0 右/1

                With ActiveDocument.Shapes.AddShape( _

                   msoShapeIsoscelesTriangle, _

                   intDxp + IIf(Kp = 0, _

                   PUMPEYVP * -1 - PUMPEYSZ, _

                   PUMPEYVP) * PUMPBZMG, _

                   intDyp + PUMPEYHP * PUMPBZMG, _

                   PUMPEYSZ * PUMPBZMG, _

                   PUMPEYSZ * PUMPBZMG)

                  .Fill.Visible = msoTrue

                  .Fill.ForeColor.RGB = lngCol(0)

                  .Line.Visible = msoFalse

                  .Flip msoFlipVertical '上下反転

               End With

            Next Kp

            '*鼻（二等辺三角形）描画

            With ActiveDocument.Shapes.AddShape( _

                msoShapeIsoscelesTriangle, _

                intDxp + (PUMPNSVP - PUMPNSWD / 2) _

                     * PUMPBZMG, _

                intDyp + PUMPNSHP * PUMPBZMG, _

                PUMPNSWD * PUMPBZMG, _

                PUMPNSHT * PUMPBZMG)

               .Fill.Visible = msoTrue

               .Fill.ForeColor.RGB = lngCol(0)

               .Line.Visible = msoFalse

            End With

            '*口描画位置設定

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

               sngP1D(Kp, 0) = sngP1B(Kp, 0) + intDxp _

                      + PUMPMTVP * PUMPBZMG

               sngP1D(Kp, 1) = sngP1B(Kp, 1) + intDyp _

                      + PUMPMTHP * PUMPBZMG

            Next Kp

            '*口(ポリライン)描画

            With ActiveDocument.Shapes.AddPolyline(sngP1D)

                .Fill.Visible = msoTrue

                .Fill.ForeColor = lngCol(0)

                .Line.Visible = msoFalse

            End With

            '*へた描画位置設定

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

                sngP2D(Kp, 0) = sngP2B(Kp, 0) + intDxp _

                      + PUMPHTVP * PUMPBZMG

                sngP2D(Kp, 1) = sngP2B(Kp, 1) + intDyp _

                      + PUMPHTHP * PUMPBZMG

            Next Kp

            With ActiveDocument.Shapes.AddPolyline(sngP2D)

                .Fill.Visible = msoTrue

                .Fill.ForeColor.RGB = lngCol(2)

                .Line.Visible = msoTrue

                .Line.ForeColor.RGB = lngCol(0)

                .Line.Weight = PUNPLNWT

           End With

        Next Ip

    Next Jp

End Sub