Option Explicit
Option Base 0
Public Sub 子持吉原繋ぎ文様描画マクロ()
Const HVCHLEFT = 100 '描画開始位置Ｘ
Const HVCHTOPP = 120 ' Ｙ
Const HVCHDISZ = 40 'ひし形の大きさ
Const HVCHDISH = HVCHDISZ \ 2
Const HVCHDICN = 5 'ひし形の太さ
'
Const HVCHKIRI = 4 'ひし形四隅切り欠け
Const HVCHROWS = 5 '縦の数
Const HVCHCOLS = 4 '横の数
'
Const HNCHDIOV = 16 'ひし形の重なり
Const HVCHDISP = 8 '横の余白
Const HVCHLNWE = 1.5 '線の太さ
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer, Kp As Integer
Dim Lp As Integer, Mp As Integer, Np As Integer
Dim intCxp As Integer, intCyp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim dblRad As Double, dblKir As Double
Dim intDRd(HVCHDICN - 1) As Integer
Dim dblKrd(HVCHDICN - 1) As Double
Dim LngCol(HVCHDICN - 1) As Long
Dim intXps(3) As Integer, intYps(3) As Integer
'
dblRad = (4 * Atn(1)) / 180
dblKir = HVCHKIRI * (1 / Sqr(2))
'*ひし形描画データ準備
For Ip = 0 To HVCHDICN - 1
intDRd(Ip) = HVCHDISH - Ip
dblKrd(Ip) = Atn(dblKir / (intDRd(Ip) - dblKir))
'線色指定
LngCol(Ip) = IIf(Ip = HVCHDICN - 2, vbWhite, RGB(0, 100, 0))
'上をコメントにして、下を生かすと、「吉原繋ぎ文様」になる。
'LngCol(Ip) = RGB(0, 100, 0)
Next Ip
'*ひし形描画
For Ip = 0 To HVCHCOLS - 1
intCxp = HVCHLEFT + (HVCHDISZ + HVCHDISP) * Ip
intDxp = intCxp + HVCHDISH
For Kp = 0 To 1 'K=0:下＼＼ 1:上／／
For Jp = 0 To HVCHROWS - 1
intCyp = HVCHTOPP + (HVCHDISZ - HNCHDIOV) * Jp
intDyp = intCyp + HVCHDISH
For Lp = 0 To HVCHDICN - 1
For Mp = 0 To 3
If (Mp Mod 2) = Kp Then
'
intXps(0) = (intDRd(Lp) - dblKir) _
* Cos(dblRad * (90 * Mp)) + intDxp
intYps(0) = (intDRd(Lp) - dblKir) * Sin(dblRad _
* (90 * Mp)) + intDyp
'
intXps(1) = intDRd(Lp) * Cos(dblRad _
* (90 * Mp) + dblKrd(Lp)) + intDxp
intYps(1) = intDRd(Lp) * Sin(dblRad _
* (90 * Mp) + dblKrd(Lp)) + intDyp
'
intXps(2) = intDRd(Lp) * Cos(dblRad _
* (90 * (Mp + 1)) - dblKrd(Lp)) + intDxp
intYps(2) = intDRd(Lp) * Sin(dblRad _
* (90 * (Mp + 1)) - dblKrd(Lp)) + intDyp
'
intXps(3) = (intDRd(Lp) - dblKir) * Cos(dblRad _
* (90 * (Mp + 1))) + intDxp
intYps(3) = (intDRd(Lp) - dblKir) * Sin(dblRad _
* (90 * (Mp + 1))) + intDyp
'*ひし形一辺描画
For Np = 0 To 2
With ActiveDocument.Shapes.AddLine(intXps(Np) , _
intYps(Np), intXps(Np + 1), intYps(Np + 1)).Line
.ForeColor.RGB = LngCol(Lp) '←線色
.Weight = HVCHLNWE '←線の太さ
End With
Next Np
End If
Next Mp '
Next Lp
Next Jp
Next Kp
Next Ip
End Sub
蛇足
前の拙作「吉原繋ぎ文様描画マクロ」に比べると、かなり綺麗に描画します。でも、かなり描画に時間を要します。作成者がヘボなので、そんなものでしょう！
