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

Option Explicit

Option Base 0

'

Public Sub サークル模様描画マクロ()

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

    Const CIRCTOPP = 100 　　　　　　  '　　　　　　Ｙ

    Const CIRCCOLS = 8                         '横/描画数

    Const CIRCROWS = 7                        '縦/描画数

    Const CIRCCONT = (CIRCCOLS * CIRCROWS)

    '

    Const CIRCSRAD = 5                         '中心円半径

    Const CIRCCSPC = 3                         '半径刻み幅

    Const CIRCCCNT = 5                         '描画円数

    '

    Const CIRCLNWT = 1.5                     '線の太さ

    '円と円の間隔

    Const CIRCVSPC = (CIRCSRAD * 2  _

                           + CIRCCSPC * (CIRCCCNT))

    Const CIRCHSPC = CIRCVSPC

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

    Dim Ip As Integer, Jp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intRad As Integer, lngCol As Long

    Dim intNtb(CIRCCONT - 1, 1) As Integer

    Dim intNTm(1) As Integer

    '

    '*描画順番テーブル設定

    Randomize                        '乱数初期化

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

        '0:順番 1:乱数

        intNtb(Ip, 0) = Ip: intNtb(Ip, 1) = CInt(Rnd * 1000 + 1)

    Next Ip

    '*描画順番テーブル、順番を乱数でシャッフル(乱数順にソート)

    Do

       Jp = 0

       For Ip = LBound(intNtb, 1) + 1 To UBound(intNtb, 1)

           If intNtb(Ip - 1, 1) > intNtb(Ip, 1) Then

              intNTm(0) = intNtb(Ip, 0)    '入れ替え

              intNTm(1) = intNtb(Ip, 1)

              intNtb(Ip, 0) = intNtb(Ip - 1, 0)

              intNtb(Ip, 1) = intNtb(Ip - 1, 1)

              intNtb(Ip - 1, 0) = intNTm(0)

              intNtb(Ip - 1, 1) = intNTm(1): Jp = Jp + 1

           End If

       Next Ip

    Loop While Jp > 0                                '入れ替え無し？

    '

   lngCol = RGB(46, 139, 87) '←線色

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

       '中心位置算出

       intCyp = CIRCTOPP + (intNtb(Ip, 0) \ CIRCCOLS) _

                         * CIRCHSPC

       intCxp = CIRCLEFT + (intNtb(Ip, 0) Mod CIRCCOLS) _

                         * CIRCVSPC _

                         + ((intNtb(Ip, 0) \ CIRCCOLS) Mod 2) _

                         * (CIRCVSPC \ 2)

       '

       For Jp = CIRCCCNT - 1 To 0 Step -1

           '*円を描画

           intRad = CIRCSRAD + CIRCCSPC * Jp

           With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                intCxp - intRad, intCyp - intRad, _

                intRad * 2, intRad * 2)

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

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

                .Line.Visible = msoTrue '←輪郭線有無

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

                .Line.Weight = CIRCLNWT '←輪郭線の太さ

           End With

       Next Jp

   Next Ip

End Sub