【Word VBA】シェルピンスキー曲線描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Const CNS_PAI As Double = 3.14159265358979 　　'π

'

Const SIERCXPT As Integer = 250　　　   '描画開始位置Ｘ

Const SIERCYPT As Integer = 250 　　　  '                  Ｙ

Const SIERLENG As Integer = 10             '辺の長さ

Const SIERORDR As Integer = 3              '次数

'

Const SIERLNCL As Long = 2263842       '線の色(緑)

Const SIERLNWT As Single = 1.5 　　　　'線の太さ

'---------------------------------------------------------------------------

Public p_intDxp As Integer 　　　　　　　'描画位置Ｘ(変数)

Public p_intDyp As Integer 　　　　　　　'　　　   Ｙ(変数)

Public p_intAng As Integer　　　　　　    '描画角度

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Public Sub シェルピンスキー曲線描画マクロ() 'Wac?aw Sierpi?ski

   Dim Ip As Integer

   '

   p_intDxp = SIERCXPT:

   p_intDyp = SIERCYPT: p_intAng = -45

   For Ip = 0 To 3

       Call シェルピンスキー曲線描画マクロ_描画(SIERLENG)

       Call シェルピンスキー曲線描画マクロ_回帰(SIERORDR)

   Next Ip

End Sub

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Public Sub シェルピンスキー曲線描画マクロ_回帰(pintNum As Integer)

    If pintNum = 0 Then

       p_intAng = p_intAng - 90: Exit Sub

    End If

    '

    Call シェルピンスキー曲線描画マクロ_回帰(pintNum - 1)

    Call シェルピンスキー曲線描画マクロ_描画(SIERLENG)

    Call シェルピンスキー曲線描画マクロ_回帰(pintNum - 1)

    p_intAng = p_intAng + 135:

    Call シェルピンスキー曲線描画マクロ_描画(SIERLENG)

    p_intAng = p_intAng + 135:

    Call シェルピンスキー曲線描画マクロ_回帰(pintNum - 1)

    Call シェルピンスキー曲線描画マクロ_描画(SIERLENG)

    Call シェルピンスキー曲線描画マクロ_回帰(pintNum - 1)

End Sub

'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*

Public Sub シェルピンスキー曲線描画マクロ_描画(pintLng As Integer)

    Dim dblAng As Double

    Dim intExp As Integer, intEyp As Integer

    '

    '*描画終点位置算出

    dblAng = p_intAng * CNS_PAI / 180

    intExp = p_intDxp + pintLng * Cos(dblAng)

    intEyp = p_intDyp + pintLng * Sin(dblAng)

    '

    '*直線描画

    With ActiveDocument.Shapes.AddLine( _

         p_intDxp, p_intDyp, intExp, intEyp).Line

        .ForeColor.RGB = SIERLNCL '←線色

        .Weight = SIERLNWT '←線の太さ

    End With

    p_intDxp = intExp: p_intDyp = intEyp

    '

    '↓時間がかかるので、挿入しました。

    DoEvents

End Sub