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

Option Explicit

Option Base 0

'

Public Sub 歯車模様描画マクロ()

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

   Const GEARTOPP = 80　　　          '　　　　　　Ｙ

   '

   Const GEARSIZ1 = 34 　 　　　　　'歯車１直径

   Const GEARSIZ2 = 25                    '歯車２

   Const GEARSIZ3 = 25                    '歯車３

   '

   Const GEARHMAG = 15                  '描画間隔（横）

   Const GEARVMAG = 15                  '描画間隔（縦）

   '

   Const GEARHGAP = 16                  '歯車２と歯車３の距離

   Const GEARVGAP = 16

   Const GEARCOLS = 5                    '横描画数

   Const GEARROWS = 4                   '縦描画数

   '

   Const GEARLNWE = 1                   '輪郭線の太さ

   Const GEARADJ1 = 0.15                '歯車の歯高さ

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

   Dim Ip As Integer, Jp As Integer

   Dim Kp As Integer

   Dim intCxp As Integer, intCyp As Integer

   Dim lngCol(3) As Long

   '

   lngCol(0) = RGB(0, 0, 0):               '←輪郭線色

   lngCol(1) = RGB(128, 128, 128)     '←歯車１色

   lngCol(2) = RGB(211, 211, 211)     '←歯車２色

   lngCol(3) = RGB(255, 140, 0)         '←歯車３色

   For Jp = 0 To GEARROWS - 1

       For Ip = 0 To GEARCOLS - 1

           intCxp = GEARLEFT + (GEARSIZ1 + GEARVMAG) * Ip _

                  + GEARSIZ1 / 2

           intCyp = GEARTOPP + (GEARSIZ1 + GEARHMAG) * Jp _

                  + GEARSIZ1 / 2

           '*歯車１描画

           With ActiveDocument.Shapes.AddShape(msoShapeGear6, _

                intCxp - GEARSIZ1 / 2, _

                intCyp - GEARSIZ1 / 2, _

                GEARSIZ1, GEARSIZ1)

               .Fill.Visible = True

               .Fill.ForeColor.RGB = lngCol(1)

               .Line.Visible = True

               .Line.ForeColor.RGB = lngCol(0)

               .Line.Weight = GEARLNWE

               .Adjustments(1) = GEARADJ1

               .Rotation = 20

           End With

            '*歯車２描画

           With ActiveDocument.Shapes.AddShape(msoShapeGear9, _

                intCxp - GEARSIZ2 / 2, _

                intCyp - GEARSIZ2 / 2, _

                GEARSIZ2, GEARSIZ2)

               .Fill.Visible = True

               .Fill.ForeColor.RGB = lngCol(2)

               .Line.Visible = True

               .Line.ForeColor.RGB = lngCol(0)

               .Line.Weight = GEARLNWE

               .Adjustments(1) = GEARADJ1

               .Rotation = 0

           End With

            '*歯車３描画

           intCxp = intCxp + GEARVGAP

           intCyp = intCyp + GEARHGAP

           With ActiveDocument.Shapes.AddShape(msoShapeGear9, _

                intCxp - GEARSIZ3 / 2, _

                intCyp - GEARSIZ3 / 2, _

                GEARSIZ3, GEARSIZ3)

               .Fill.Visible = True

               .Fill.ForeColor.RGB = lngCol(3)

               .Line.Visible = True

               .Line.ForeColor.RGB = lngCol(0)

               .Line.Weight = GEARLNWE

               .Adjustments(1) = GEARADJ1

               .Rotation = -10

          End With

       Next Ip

   Next Jp

End Sub