Option Explicit
Option Base 0
'
Public Sub 雷紋模様描画マクロ()
Const THUNLEFT = 100 '描画開始位置X
Const THUNTOPP = 80 ' Y
Const THUNMAGN = 2 '描画倍率
Const THUNCOLS = 3 '横描画数
Const THUNROWS = 5 '縦描画数
'---------------------------------------------------------------------------
Dim Ip As Integer, Jp As Integer
Dim Kp As Integer
Dim intDxp As Integer, intDyp As Integer
Dim varPos As Variant, lngCol As Long
Dim sngBas() As Single, sngDat() As Single
'
varPos = Array(7, 7, 8, 7, 8, 5, 5, 5, 5, 9, 10, 9, _
10, 3, 3, 3, 3, 11, 12, 11, 12, 1, 1, _
1, 1, 13, 14, 13, 14, 1, 27, 1, 27, 13, _
16, 13, 16, 3, 25, 3, 25, 11, 18, 11, _
18, 5, 23, 5, 23, 9, 20, 9, 20, 7, 21, 7)
'
lngCol = vbRed '←線色
Ip = (UBound(varPos, 1) - 1) \ 2
ReDim sngBas(Ip, 1), sngDat(Ip, 1)
'*ポリラインデータ設定
For Ip = LBound(varPos, 1) To UBound(varPos, 1) Step 2
sngBas(Ip \ 2, 0) = CSng(varPos(Ip + 0)) * THUNMAGN
sngBas(Ip \ 2, 1) = CSng(varPos(Ip + 1)) * THUNMAGN
Next Ip
'
For Jp = 0 To THUNROWS - 1
intDyp = THUNTOPP + 14 * THUNMAGN * Jp
For Ip = 0 To THUNCOLS - 1
intDxp = THUNLEFT + 28 * THUNMAGN * 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 = msoFalse
.Line.ForeColor = lngCol '←線色
.Line.Weight = THUNMAGN '←線の太さ
.Line.DashStyle = msoLineSolid '←線種
If (Jp Mod 2) = 1 Then
.Flip msoFlipVertical
End If
End With
Next Ip
Next Jp
End Sub