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

Option Explicit

Option Base 0

'

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

    Const DOCRLEFT = 80         '描画開始位置Ｘ

    Const DOCRTOPP = 80        '　　　　　　Ｙ

    '

    Const DOCRCOLS = 7          '横/描画数(奇数)

    Const DOCRROWS = 7         '縦/描画数(奇数)

    '

    Const DOCRCOLH = ((DOCRCOLS - 1) / 2)     'Half

    Const DOCRROWH = ((DOCRROWS - 1) / 2)

    '

    Const DOCRDMT1 = 30          '大きな円の直径

    Const DOCRRAD1 = (DOCRDMT1 / 2)

    Const DOCRDMT2 = 18          '小さな円の直径

    Const DOCRRAD2 = (DOCRDMT2 / 2)

    Const DOCRDIFF = (DOCRRAD1 - DOCRRAD2)

    '

    Const DOCRLNCL = &H45FF   '線の色(OrangeRed)

    Const DOCRLNWE = 1           '線の太さ

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

    Dim Ip As Integer, Jp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp As Integer, intEyp As Integer

    Dim sngAng As Single

    '

    For Jp = 0 To DOCRROWS - 1

        intDyp = DOCRTOPP + DOCRDMT1 * Jp

        For Ip = 0 To DOCRCOLS - 1

            intDxp = DOCRLEFT + DOCRDMT1 * Ip

            '*外円描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                 intDxp, intDyp, DOCRDMT1, DOCRDMT1)

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

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

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

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

            End With

            '*塗りつぶし円の位置を算出

            If Ip <> DOCRCOLH Then

               If Ip < DOCRCOLH Then

                  sngAng = Atn((Jp - DOCRROWH) / (Ip - DOCRCOLH))

               Else

                  sngAng = Atn((Jp - DOCRROWH) / (Ip - DOCRCOLH)) _

                         + Atn(1) * 4

               End If

            Else

               If Jp < DOCRROWH Then

                  sngAng = Atn(1) * 2

               Else

                  sngAng = Atn(-1) * 2

               End If

            End If

            If Ip <> DOCRCOLH Or Jp <> DOCRROWH Then

               intExp = DOCRDIFF * Cos(sngAng) + intDxp _

                                 + DOCRRAD1

               intEyp = DOCRDIFF * Sin(sngAng) + intDyp _

                                 + DOCRRAD1

            Else

              intExp = intDxp + DOCRDMT1 / 2

              intEyp = intDyp + DOCRDMT1 / 2

            End If

            '*塗りつぶし円描画

            With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                 intExp - DOCRRAD2, _

                 intEyp - DOCRRAD2, DOCRDMT2, DOCRDMT2)

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

                .Fill.ForeColor.RGB = DOCRLNCL     '←塗潰し色

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

            End With

        Next Ip

    Next Jp

End Sub