【Word VBA】雪輪文様描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 雪輪文様描画マクロ()

    Const SNOWLEFT = 90　　　          '描画開始位置Ｘ

    Const SNOWTOPP = 90　　　         '　　　　　　Ｙ

    '

    Const SNOWHZSP = 70 　　  　　　'水平間隔

    Const SNOWVTSP = 70                  '垂直間隔

    '

    Const SNOWCOLS = 3                   '横 描画数

    Const SNOWROWS = 3                  '縦 描画数

    '

    Const SNOWLNWT = 1                  '線の太さ

    '

    Const SNOWSZ1 = 20                    '雪輪半径１

    Const SNOWSZ2 = 10                    '雪輪半径２

    Const SNOWGAP = 3                     '雪輪の隙間

    '

    Const SNOWARCA = 40                 '円弧描画角

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

    Dim Ip As Integer, Jp As Integer

    Dim Kp As Integer, Lp As Integer

    Dim intCxp As Integer, intCyp As Integer

    Dim intDxp As Integer, intDyp As Integer

    Dim intExp(1) As Integer, intEyp(1) As Integer

    Dim dblRad As Double, intAgl As Integer

    Dim intRdn As Integer, intFrd As Integer

    Dim lngCol As Long

    '

    '

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

    lngCol = RGB(65, 105, 225) '←線色

    For Jp = 0 To SNOWROWS - 1

        intCyp = SNOWTOPP + SNOWHZSP * Jp

        For Ip = 0 To SNOWCOLS - 1

            intCxp = SNOWLEFT + SNOWVTSP * Ip

            For Kp = 1 To 2

                intDxp = intCxp  _

                + Choose(Kp, SNOWSZ1 + SNOWSZ2 + SNOWGAP, 0)

                intDyp = intCyp  _

                + Choose(Kp, SNOWSZ1 + SNOWSZ2 + SNOWGAP, 0)

                intRdn = Choose(Kp, SNOWSZ1, SNOWSZ2)

                intFrd = intRdn * Tan(dblRad * (SNOWARCA / 2))

                For Lp = 0 To 5

                    intAgl = 60 * Lp

                    intExp(0) = intRdn * Cos(dblRad * intAgl) + intDxp

                    intEyp(0) = intRdn * Sin(dblRad * intAgl) + intDyp

                    intExp(1) = intRdn  _

                                 * Cos(dblRad * (intAgl + SNOWARCA)) + intDxp

                    intEyp(1) = intRdn  _

                                 * Sin(dblRad * (intAgl + SNOWARCA)) + intDyp

                    '*円弧１描画

                    With ActiveDocument.Shapes.AddShape(msoShapeArc, _

                         (intExp(1) + intExp(0)) / 2 - intFrd, _

                         (intEyp(1) + intEyp(0)) / 2 - intFrd / 2, _

                              intFrd * 2, intFrd * 1)

                        .Fill.Visible = False

                        .Line.Visible = True

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

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

                        .Adjustments(1) = 0

                        .Adjustments(2) = 180

                        .Rotation = intAgl - 90 + 20

                    End With

                    '*円弧２描画

                    With ActiveDocument.Shapes.AddShape(msoShapeArc, _

                        intDxp - intRdn, intDyp - intRdn, _

                              intRdn * 2, intRdn * 2)

                        .Fill.Visible = False

                        .Line.Visible = True

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

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

                        .Adjustments(1) = intAgl + SNOWARCA

                        .Adjustments(2) = intAgl + 60

                    End With

                    '*小穴描画

                    intExp(0) = intRdn  _

                             * Cos(dblRad * (intAgl + SNOWARCA / 2)) + intDxp

                    intEyp(0) = intRdn  _

                             * Sin(dblRad * (intAgl + SNOWARCA / 2)) + intDyp

                    With ActiveDocument.Shapes.AddShape(msoShapeOval, _

                         intExp(0) - intFrd / 4, intEyp(0) - intFrd / 4, _

                              intFrd / 2, intFrd / 2)

                        .Fill.Visible = msoTrue

                        .Fill.ForeColor.RGB = vbWhite

                        .Line.Visible = msoTrue

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

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

                   End With

                Next Lp

            Next Kp

        Next Ip

    Next Jp

End Sub

《蛇足》

　無骨な形が雪っぽいとは、無能な作者の下手な言い訳！