【Word VBA】多重円模様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 多重円模様描画マクロ()

    Const MLTCLEFT = 180　　    '描画開始位置Ｘ

    Const MLTCTOPP = 160 　　  '　　　　　　Ｙ

    Const MLTCRADI = 10           '描画開始半径

    Const MLTCCONT = 10          '描画円数

    '

    Const MLTCLNWT = 2           '線の太さ

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

    Dim Ip As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intCrd As Integer, lngCol As Long

    '

    lngCol = RGB(148, 0, 211)           '←線の色

    intCxp = MLTCLEFT: intCyp = MLTCTOPP

    intCrd = MLTCRADI

    For Ip = 0 To MLTCCONT - 1

        ' 円形を描画し ます

        With ActiveDocument.Shapes.AddShape( _

             msoShapeOval, _

             intCxp - intCrd, _

             intCyp - intCrd, _

             intCrd * 2, intCrd * 2)

             .Fill.Visible = msoFalse

             .Line.Visible = msoTrue

             .Line.ForeColor.RGB = lngCol   '←線の色

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

        End With

        intCyp = intCyp + (intCrd / (Ip + 1)) _

               * IIf((Ip Mod 2) = 0, 1, -1)

        intCrd = intCrd * (1 + 1 / (Ip + 1))

    Next Ip

End Sub