【Word VBA】捻り梅描画マクロ▽ソースコード
記事IT・テクノロジー
Option Explicit
Option Base 0
'
Public Sub 捻り梅描画マクロ()
Const TWPLLEFT = 80 '描画開始位置Ｘ
Const TWPLTOPP = 80 ' Ｙ
'
Const TWPLCOLS = 5 '横/描画数
Const TWPLROWS = 4 '縦/描画数
'
Const TWPLBZMG = 0.2 'ベジェ曲線描画倍率
Const TWPLFRAD = 74.35 * TWPLBZMG '花びら中心位置
Const TWPLARAD = 40.01 * TWPLBZMG '花びらしわサイズ
Const TWPLHEIG = 56.36 * TWPLBZMG ' 〃
Const TWPLCRAD = 25.01 * TWPLBZMG '真ん中の円半径
Const TWPLLNWE = 1.5 '線の太さ
'
Const TWPLVPIT = TWPLFRAD *4 '横/描画間隔
Const TWPLHPIT = TWPLFRAD * 4 '縦/描画間隔
'---------------------------------------------------------------------------
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 sngBBas() As Single, sngBDat() As Single
Dim varBezi As Variant
Dim lngCol(1) As Long, sngRad As Single
'
'*花びら(ベジエ曲線)データ
varBezi = Array(-19.42, -69.25, -23.37, -67.89, -27.72, -65.82, -31.26, -63.67, -34.81, -61.53, -37.73, -59.28, -40.67, -56.36, -43.61, -53.43, -46.96, -49.56, -48.9, -46.11, -50.85, -42.65, -52.7, -38.38, -53.91, -33.01, -55.12, -27.63, -56.49, -20.76, -56.17, -13.84, -55.86, -6.91, -53.8, 2.07, -51.99, 8.55, -50.19, 15.04, -48.35, 19.63, -45.37, 25.08, -42.38, 30.53, -38.79, 36.02, -34.07, 41.26, -29.35, 46.49, -22.85, 51.3, -17.04, 56.46, -11.23, 61.63, -2.58, 72.73, 0.78, 72.24, 4.15, 71.75, _
1.41, 60.02, 3.15, 53.5, 4.89, 46.98, 8.04, 39.34, 11.21, 33.14, 14.38, 26.93, 18.47, 21.08, 22.19, 16.26, 25.9, 11.43, 29.28, 7.89, 33.52, 4.18, 37.75, 0.47, 43.93, -2.98, 47.58, -5.99, 51.23, -9#, 54.32, -9.83, 55.41, -13.87, 56.49, -17.9, 54.92, -25.72, 54.09, -30.22, 53.27, -34.71, 52.38, -37.07, 50.44, -40.85, 48.49, -44.62, 45.27, -49.48, 42.42, -52.87, 39.57, -56.26, 35.61, -59.68, 33.34, -61.19, 31.08, -62.7, 27.84, -65#, 24.48, -66.64, _
21.12, -68.27, 16.5, -70.03, 13.16, -70.99, 9.82, -71.96, 4.45, -72.44, 4.45, -72.44, 1.81, -72.73, -3.6, -72.35, -7.58, -71.82, -11.55, -71.28, -15.47, -70.61, -19.42, -69.25)
'
'*花びら(ベジエ曲線)データ設定
ReDim sngBBas((UBound(varBezi, 1) - 1) \ 2, 1)
ReDim sngBDat((UBound(varBezi, 1) - 1) \ 2, 1)
For Kp = LBound(sngBBas, 1) To UBound(sngBBas, 1)
sngBBas(Kp, 0) = CSng(varBezi(Kp * 2 + 0)) * TWPLBZMG
sngBBas(Kp, 1) = CSng(varBezi(Kp * 2 + 1)) * TWPLBZMG
Next Kp
'
sngRad = Atn(1) / 45
For Jp = 0 To TWPLROWS - 1
intCyp = TWPLTOPP + TWPLHPIT * Jp + TWPLFRAD * 2
'
If (Jp Mod 2) = 0 Then
lngCol(0) = vbBlack '←線色
lngCol(1) = RGB(255, 105, 180) '←塗りつぶし色
Else
lngCol(0) = RGB(255, 105, 180) '←線色
lngCol(1) = vbWhite '←塗りつぶし色
End If
For Ip = 0 To TWPLCOLS - IIf((Jp Mod 2) = 0, 1, 2)
intCxp = TWPLLEFT + TWPLVPIT * Ip + TWPLFRAD * 2 _
+ (TWPLVPIT / 2) * (Jp Mod 2)
'
For Lp = 0 To 4
intDxp = TWPLFRAD * Cos(sngRad * (72 * Lp)) + intCxp
intDyp = TWPLFRAD * Sin(sngRad * (72 * Lp)) + intCyp
'*花びら(ベジエ曲線)位置設定
For Kp = LBound(sngBDat, 1) To UBound(sngBDat, 1)
sngBDat(Kp, 0) = sngBBas(Kp, 0) + intDxp
sngBDat(Kp, 1) = sngBBas(Kp, 1) + intDyp
Next Kp
'*花びら(ベジエ曲線)描画
With ActiveDocument.Shapes.AddCurve(sngBDat)
.Fill.Visible = msoTrue
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngCol(0)
.Fill.ForeColor.RGB = lngCol(1)
.Line.Weight = TWPLLNWE
.Rotation = (72 * Lp) + 90
End With
'*花びらしわ（円弧）位置設定
intDxp = TWPLARAD * Cos(sngRad * (72 * Lp)) + intCxp
intDyp = TWPLARAD * Sin(sngRad * (72 * Lp)) + intCyp
'*花びらしわ（円弧）描画
With ActiveDocument.Shapes.AddShape(msoShapeArc, _
intDxp - TWPLARAD, intDyp - TWPLHEIG / 4, _
TWPLARAD * 2, TWPLHEIG / 2)
.Adjustments(1) = 180 '←半円カーブ
.Adjustments(2) = 360
.Line.ForeColor = lngCol(0)
.Line.Weight = TWPLLNWE
.Rotation = (72 * Lp) - 10
End With
Next Lp
'*中心円描画
With ActiveDocument.Shapes.AddShape(msoShapeOval, _
intCxp - TWPLCRAD, intCyp - TWPLCRAD, _
TWPLCRAD * 2, TWPLCRAD * 2)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = lngCol(1)
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngCol(0)
.Line.Weight = TWPLLNWE
End With
Next Ip
Next Jp
End Sub
