【Word VBA】皆違って皆いい描画マクロ▽ソースコード
記事IT・テクノロジー
Option Explicit
Option Base 0
'金子みすゞの詩『私と小鳥と鈴と』の一節より
Public Sub 皆違って皆いい描画マクロ()
Const KANELEFT = 80 '描画開始位置Ｘ
Const KANETOPP = 80 ' Ｙ
'
Const KANEVPIT = 75 '横-間隔
Const KANEHPIT = 75 '縦-間隔
Const KANECOLS = 4 '横/描画数
Const KANEROWS = 3 '縦/描画数
'
Const KANELNWE = 1 '線の太さ
'
'ベジエ曲線描画倍率
Const KANEBZR顔 = 0.9
Const KANEBZR目 = 0.2
Const KANEBZR鼻 = -0.3
Const KANEBZR口 = -0.25
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, Kp As Integer
Dim Lp As Integer, intDlt As Integer
Dim intCxp As Integer, intCyp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim varB顔 As Variant, varB目 As Variant
Dim varB鼻 As Variant, varB口 As Variant
Dim sngB顔() As Single, sngD顔() As Single
Dim sngB目() As Single, sngD目() As Single
Dim sngB鼻() As Single, sngD鼻() As Single
Dim sngB口() As Single, sngD口() As Single
Dim lngC顔 As Long, lngC口 As Long, lngCol As Long
'
varB顔 = Array(0.3, 46.5, 49.5, 29.1, 50.4, -29.4, 0#, -33.3, _
-41.7, -30#, -51#, 28.8, -0.3, 46.5)
varB目 = Array(54#, -0.3, 36#, -30.3, -26.4, -30.6, -51.6, -0.3, _
-35.7, 19.8, 36.9, 19.5, 53.1, 0#)
varB鼻 = Array(0.9, 52.5, 21#, 11.1, 46.8, -19.8, 0.6, -33.6, _
-47.1, -20.4, -22.5, 9#, 0#, 52.8)
varB口 = Array(-1.2, 9#, 24.6, 29.4, 43.8, 7.2, 59.4, 0#, _
26.7, -18.9, -23.4, -22.8, -62.1, -0.3, -45.3, 5.1, _
-26.7, 29.1, -0.6, 9.3)
'
ReDim sngB顔((UBound(varB顔, 1) - 1) \ 2, 1)
ReDim sngD顔((UBound(varB顔, 1) - 1) \ 2, 1)
'
For Kp = LBound(sngB顔, 1) To UBound(sngB顔, 1)
sngB顔(Kp, 0) = CSng(varB顔(Kp * 2 + 0)) * KANEBZR顔
sngB顔(Kp, 1) = CSng(varB顔(Kp * 2 + 1)) * KANEBZR顔
Next Kp
'
ReDim sngB目((UBound(varB目, 1) - 1) \ 2, 1)
ReDim sngD目((UBound(varB目, 1) - 1) \ 2, 1)
'
For Kp = LBound(sngB目, 1) To UBound(sngB目, 1)
sngB目(Kp, 0) = CSng(varB目(Kp * 2 + 0)) * KANEBZR目
sngB目(Kp, 1) = CSng(varB目(Kp * 2 + 1)) * KANEBZR目
Next Kp
'
ReDim sngB鼻((UBound(varB鼻, 1) - 1) \ 2, 1)
ReDim sngD鼻((UBound(varB鼻, 1) - 1) \ 2, 1)
For Kp = LBound(sngB鼻, 1) To UBound(sngB鼻, 1)
sngB鼻(Kp, 0) = CSng(varB鼻(Kp * 2 + 0)) * KANEBZR鼻
sngB鼻(Kp, 1) = CSng(varB鼻(Kp * 2 + 1)) * KANEBZR鼻
Next Kp
'
ReDim sngB口((UBound(varB口, 1) - 1) \ 2, 1)
ReDim sngD口((UBound(varB口, 1) - 1) \ 2, 1)
For Kp = LBound(sngB口, 1) To UBound(sngB口, 1)
sngB口(Kp, 0) = CSng(varB口(Kp * 2 + 0)) * KANEBZR口
sngB口(Kp, 1) = CSng(varB口(Kp * 2 + 1)) * KANEBZR口
Next Kp
'
Randomize '*乱数系列初期化
lngCol = vbBlack '←輪郭線色
lngC口 = RGB(220, 20, 60)
For Jp = 0 To KANEROWS - 1
intCyp = KANETOPP + KANEHPIT * Jp _
+ (KANEHPIT \ 2)
For Ip = 0 To KANECOLS - 1
intCxp = KANELEFT + KANEVPIT * Ip _
+ (KANEVPIT \ 2)
'*顔の色を乱数で変える
lngC顔 = Choose(Int(4 * Rnd + 1), _
RGB(233, 150, 122), RGB(250, 128, 114), _
RGB(240, 128, 128), RGB(178, 34, 34))
'
For Kp = LBound(sngD顔, 1) To UBound(sngD顔, 1)
sngD顔(Kp, 0) = sngB顔(Kp, 0) + intCxp
sngD顔(Kp, 1) = sngB顔(Kp, 1) + intCyp
Next Kp
'*顔の形を乱数でちょっと変える
intDlt = Int((KANEVPIT / 5) * Rnd) - (KANEVPIT / (5 * 2))
sngD顔(1, 0) = sngD顔(1, 0) - intDlt
sngD顔(5, 0) = sngD顔(5, 0) + intDlt
With ActiveDocument.Shapes.AddCurve(sngD顔)
.Fill.Visible = msoTrue
.Line.Visible = msoTrue
.Fill.ForeColor.RGB = lngC顔
.Line.ForeColor.RGB = lngCol
.Line.Weight = KANELNWE
End With
'
'*目の形や位置を乱数でちょっと変える
intDlt = Int((KANEHPIT / 15) * Rnd) - (KANEHPIT / (15 * 2))
intDyp = intCyp - KANEHPIT / 10 - intDlt
For Lp = 0 To 1
intDxp = intCxp + (KANEVPIT / 5) _
* IIf(Lp = 0, -1, 1)
For Kp = LBound(sngD目, 1) To UBound(sngD目, 1)
sngD目(Kp, 0) = sngB目(Kp, 0) + intDxp
sngD目(Kp, 1) = sngB目(Kp, 1) + intDyp
Next Kp
sngD目(1, 1) = sngD目(1, 1) + intDlt
sngD目(2, 1) = sngD目(2, 1) + intDlt
sngD目(4, 1) = sngD目(4, 1) - intDlt
sngD目(5, 1) = sngD目(5, 1) - intDlt
'
With ActiveDocument.Shapes.AddCurve(sngD目)
.Fill.Visible = msoTrue
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngCol
.Fill.ForeColor.RGB = vbWhite
.Line.Weight = KANELNWE
End With
'
With ActiveDocument.Shapes.AddShape(msoShapeOval, _
intDxp - 3, intDyp - 3, 6, 6)
.Fill.Visible = msoTrue
.Line.Visible = msoFalse
.Fill.ForeColor.RGB = vbBlack
End With
Next Lp
For Kp = LBound(sngD鼻, 1) To UBound(sngD鼻, 1)
sngD鼻(Kp, 0) = sngB鼻(Kp, 0) + intCxp
sngD鼻(Kp, 1) = sngB鼻(Kp, 1) + intCyp _
+ KANEHPIT / 10
Next Kp
'
'*鼻の形を乱数でちょっと変える
intDlt = Int((KANEVPIT / 5) * Rnd) - (KANEVPIT / (5 * 2))
sngD鼻(2, 0) = sngD鼻(2, 0) + intDlt
sngD鼻(4, 0) = sngD鼻(4, 0) - intDlt
'
With ActiveDocument.Shapes.AddCurve(sngD鼻)
.Fill.Visible = msoTrue
.Line.Visible = msoTrue
.Fill.ForeColor.RGB = lngC顔
.Line.ForeColor.RGB = lngCol
.Line.Weight = KANELNWE
End With
'
For Kp = LBound(sngD口, 1) To UBound(sngD口, 1)
sngD口(Kp, 0) = sngB口(Kp, 0) + intCxp
sngD口(Kp, 1) = sngB口(Kp, 1) + intCyp _
+ KANEHPIT / 2.8
Next Kp
'
'*口の形を乱数でちょっと変える
intDlt = Int((KANEVPIT / 10) * Rnd) - (KANEVPIT / (10 * 2))
sngD口(3, 0) = sngD口(3, 0) + intDlt
sngD口(6, 0) = sngD口(6, 0) - intDlt
With ActiveDocument.Shapes.AddCurve(sngD口)
.Fill.Visible = msoTrue
.Line.Visible = msoTrue
.Fill.ForeColor.RGB = lngC口
.Line.ForeColor.RGB = lngCol
.Line.Weight = KANELNWE
End With
With ActiveDocument.Shapes.AddLine( _
sngD口(3, 0), sngD口(3, 1), _
sngD口(6, 0), sngD口(6, 1)).Line
.ForeColor.RGB = lngCol '←線色
.Weight = KANELNWE '←線の太さ
End With
Next Ip
Next Jp
Exit Sub
End Sub
蛇足
マクロ(VBA)では、変数に全角文字（日本語)が使えるので、今回やってみたが、命令語の英数半角と混在するから、やはり作りづらい。それも、慣れてくると、違うのかもしれない。そんなマクロのソースコードを含めて、「皆違って皆いい」と思う。
