Option Explicit
Option Base 0
Public Sub 竹縞模様描画マクロ()
Const BAMBLEFT = 90 '描画開始位置Ｘ
Const BAMBTOPP = 80 ' Ｙ
Const BAMBHEIG = 180 '描画高さ
'
Const BAMBTWID = 15 '節の幅
Const BAMBSCHT = 3 '節の高さ
Const BAMBVSPC = 30 '横-間隔
Const BAMBCOLS = 7 '横/描画数
Const BAMBSECS = 4 '節の数
Const BAMBSHEI = (BAMBHEIG \ BAMBSECS)
'
Const BAMBSECP = 0.3 '節の凸傾斜
Const BAMBLNWE = 1 '線の太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim intDhe(BAMBSECS) As Integer
Dim intDwd As Integer, lngCol(1) As Long
'
lngCol(0) = vbBlack '←輪郭線色
lngCol(1) = RGB(34, 139, 34) '←竹の色
intDwd = BAMBTWID - (BAMBSCHT * BAMBSECP) * 2
Randomize '*乱数系列初期化
For Ip = 0 To BAMBCOLS - 1
intDxp = BAMBLEFT + BAMBVSPC * Ip + BAMBVSPC \ 2
'*節の位置設定
intDhe(BAMBSECS) = 0
For Jp = 0 To BAMBSECS - 1
If Jp < BAMBSECS - 1 Then
'乱数で筒長に長短をつける
intDhe(Jp) = BAMBSHEI + _
(BAMBSHEI / 2) * (Rnd - 0.5)
Else
intDhe(Jp) = BAMBHEIG - intDhe(BAMBSECS)
End If
intDhe(BAMBSECS) = intDhe(BAMBSECS) + intDhe(Jp)
Next Jp
intDyp = BAMBTOPP
For Jp = 0 To BAMBSECS - 1
'*竹の筒（長方形）描画
With ActiveDocument.Shapes.AddShape( _
msoShapeRectangle, _
intDxp - intDwd / 2, intDyp, _
intDwd, intDhe(Jp) _
- IIf(Jp < BAMBSECS - 1, BAMBSCHT, 0))
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = lngCol(1)
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngCol(0)
.Line.Weight = BAMBLNWE
End With
If Jp < BAMBSECS - 1 Then
'*竹の節（六角形）描画
With ActiveDocument.Shapes.AddShape( _
msoShapeHexagon, _
intDxp - BAMBTWID / 2, _
intDyp + intDhe(Jp) - BAMBSCHT, _
BAMBTWID, BAMBSCHT)
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = lngCol(1)
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngCol(0)
.Line.Weight = BAMBLNWE
.Adjustments(1) = BAMBSECP
End With
'*竹の節の線を描画
With ActiveDocument.Shapes.AddLine( _
intDxp - intDwd / 2, _
intDyp + intDhe(Jp) - BAMBSCHT / 2, _
intDxp + intDwd / 2, _
intDyp + intDhe(Jp) - BAMBSCHT / 2).Line
.ForeColor.RGB = lngCol(0)
.Weight = BAMBLNWE
End With
End If
'描画位置を更新
intDyp = intDyp + intDhe(Jp)
Next Jp
Next Ip
End Sub
