Option Explicit
Option Base 0
'
Public Sub もみじ描画マクロ()
Const MAPLLEFT = 100 '描画開始位置Ｘ
Const MAPLTOPP = 100 ' Ｙ
'
Const MAPLVSPC = 50 '横-間隔
Const MAPLHSPC = 50 '縦-間隔
Const MAPLCOLS = 5 '横/描画数
Const MAPLROWS = 4 '縦/描画数
'
Const MAPLLNWE = 1 '線の太さ
'
Const MAPLRATE = 0.75 'ポリライン倍率
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim Kp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim varPly As Variant
Dim sngBas() As Single, sngDat() As Single
'
'*ポリラインデータ
varPly = Array(0.3, -31.5, 0.3, -31.5, -2.2, -23.6, -3.1, -20.6, -4#, _
-20.4, -6.1, -14.5, -6.8, -9.2, -6.6, -6.7, -6#, -2.6, -4.6, 1.6, -1.5, _
6.6, 0.4, 9#, 0.6, 9.8, 0.7, 10.8, -1.5, 10.2, -3.5, 7#, -6.2, 3.2, _
-8.3, 1.3, -12.1, -0.5, -17.8, -2.6, -23.2, -3.4, -23.2, -2.8, -31.8, _
-5.2, -26.6, 0.6, -24.8, 2.8, -25.7, 3.4, -21.8, 7.4, -22.5, 7.7, -18.3, _
12.1, -16.4, 13.3, -13.3, 14.9, -10.9, 15.5, -7.6, 15.9, -3.8, 15.8, _
-1.7, 15.7, -1.7, 15.7, -1.5, 15.9, -4.1, 16.2, -6#, 16.6, -8.7, _
16.8, -12.4, 18#, -14.3, 19.4, -16#, 20.8, -17.9, 22.6, -16.8, 23.4, _
-20.5, 25.4, -23.7, 27.5, -16.9, 27.2, -13.6, 26.4, -13.6, 27#, -8.6, _
26.8, -5.2, 26.2, -2.3, 24.8, -0.2, 22.9, 2.1, 20.8, 3.8, 18.3, _
4.2, 17.2, 5.7, 24.6, 6.8, 28.9, 8.1, 32.7, 8.7, 33.9, 8.7, 33.6, 9.5, _
34#, 7.7, 30#, 6.4, 25.3, 5.5, 21.2, 5.1, 18.1, 4.8, 17.4, 6.6, 19.2, _
9.2, 21.2, 11#, 21.4, 13.6, 22.4, 16.8, 22.4, 19.6, 21.8, 23#, 20.7, _
28.5, 19.8, 23.3, 17.4, 23.8, 17.2, 19.6, 15.7, 20.1, 15.5, 14.1, 14#, _
19.3, 11.6, 20.3, 10.4, 22.8, 9.3, 25.8, 7#, 27.7, 4.6, 29#, 1.4, 30.3, _
-2#, 30.6, -4.5, 25.9, -3.4, 22.5, -2.5, 19.3, -1.8, 15.6, 0.4, 12.3, _
3.4, 9.7, 5.7, 7.7, 9#, 7.6, 5.8, 8#, 3#, 9.2, -1.2, 10.4, -4.6, 10.6, _
-7.8, 9.3, -10.7, 8.9, -9.9, 8.3, -14.1, 7.8, -16.9, 6.8, -19.2, 6.7, _
-17.7, 4.8, -21.7, 3.9, -24.9, 2.2, -29.1, 0.1, -31.9, 0, -31.5)
'*ポリラインデータ設定
ReDim sngBas((UBound(varPly, 1) - 1) \ 2, 1)
ReDim sngDat((UBound(varPly, 1) - 1) \ 2, 1)
For Kp = LBound(varPly, 1) To UBound(varPly, 1) Step 2
sngBas(Kp \ 2, 0) = CSng(varPly(Kp + 0)) * MAPLRATE
sngBas(Kp \ 2, 1) = CSng(varPly(Kp + 1)) * MAPLRATE
Next Kp '
'
For Jp = 0 To MAPLROWS - 1
intDyp = MAPLTOPP + (MAPLHSPC) * Jp
For Ip = 0 To MAPLCOLS - 1
intDxp = MAPLLEFT + (MAPLVSPC) * Ip
For Kp = LBound(sngBas, 1) To UBound(sngBas, 1)
sngDat(Kp, 0) = sngBas(Kp, 0) + intDxp
sngDat(Kp, 1) = sngBas(Kp, 1) + intDyp
Next Kp
With ActiveDocument.Shapes.AddPolyline(sngDat)
.Fill.Visible = msoTrue
'↓グラデーション
.Fill.TwoColorGradient (Ip Mod 3) + 2, (Jp Mod 2) + 1
.Fill.ForeColor = vbRed
.Fill.BackColor = vbYellow
.Line.Visible = msoTrue
.Line.ForeColor = vbBlack '←線色
.Line.Weight = MAPLLNWE '←線の太さ
End With
Next Ip
Next Jp
End Sub
