【Word VBA】渦巻き状に三日月描画マクロ▽ソースコード

Option Explicit

Option Base 0

Public Sub 渦巻き状に三日月描画マクロ()

    Const CIRCXPOS = 200                        '輪の中心位置　X

    Const CIRCYPOS = 160                        '                     Y

    Const CIRCRADI = 100                        '輪の半径

    Const CIRCRADP = 0.1                        '輪の半径の膨張率

    '

    Const SATECONT = 18                         '三日月の数

    Const SATERADI = 10                          '三日月の半径(Base)

    Const SATECNPC = 12                         '三日月の数/一周

    Const SATERADP = 0.1                        '三日月の半径の膨張率

    Const SATERADF = 0.04                       '三日月の満ち率

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

    Dim Ip As Integer, intAng As Integer

    Dim intXp As Integer, intYp As Integer, dblRd As Double

    Dim intRa As Integer

    '

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

    intAng = 360 \ SATECNPC

    For Ip = 0 To SATECONT - 1

        intXp = (Ip * CIRCRADP) * CIRCRADI _

                         * Cos(dblRd * (intAng * Ip))  + CIRCXPOS

        intYp = (Ip *  CIRCRADP) * CIRCRADI _

                         * Sin(dblRd * (intAng * Ip))   + CIRCYPOS

'

        intRa = SATERADI * (1 + SATERADP * Ip)

        With ActiveDocument.Shapes.AddShape(msoShapeMoon, _

                intXp - intRa, intYp - intRa,   intRa * 2, intRa * 2)

               .Fill.ForeColor.RGB = vbYellow           '←塗りつぶし色

               .Fill.Visible = True                             '←塗りつぶし有無

               .Line.ForeColor.RGB = vbMagenta      '←線色

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

               .Line.Visible = True                           '←線の有無

               '

               .Adjustments(1) = SATERADF* Ip

               .Rotation = intAng * Ip + 90

         End With

    Next Ip

End Sub

Public Sub 渦巻き状に円描画マクロ()

    Const CIRCXPOS = 200                     '輪の中心位置　X

    Const CIRCYPOS = 160                     '                     Y

    Const CIRCRADI = 100                     '輪の半径

    Const CIRCRADP = 0.1                     '輪の半径の膨張率

    '

    Const SATECONT = 18                     '円の数

    Const SATERADI = 10                      '円の半径(Base)

    Const SATECNPC = 12                     '円の数/一周

    Const SATERADP = 0.1                    '円の半径の膨張率

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

    Dim Ip As Integer, intAng As Integer

    Dim intXp As Integer, intYp As Integer, dblRd As Double

    Dim intRa As Integer

    '

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

    intAng = 360 \ SATECNPC

    For Ip = 0 To SATECONT - 1

        intXp = (Ip * CIRCRADP) * CIRCRADI  _

                  * Cos(dblRd * (intAng * Ip)) + CIRCXPOS

        intYp = (Ip * CIRCRADP) * CIRCRADI  _

                  * Sin(dblRd * (intAng * Ip)) + CIRCYPOS

'

        intRa = SATERADI * (1 + SATERADP * Ip)

        With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                           intXp - intRa, intYp - intRa,   intRa * 2, intRa * 2)

               .Fill.ForeColor.RGB = vbYellow                '←塗りつぶし色

               .Fill.Visible = True                                  '←塗りつぶし有無

               .Line.ForeColor.RGB = vbRed                  '←線色

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

               .Line.Visible = True                                '←線の有無

         End With

    Next Ip

End Sub