ｺｯﾎ曲線を描く

こちらの12年も前の記事なのですが、楽しそうなので
CATIAで行ってみました。
再帰プログラムによるフラクタル図形の描画：CodeZine（コードジン）

'vba sample_Koch_Curve_ver0.0.1  using-'KCL0.0.12'  by Kantoku
'xy平面上にｺｯﾎ曲線を作成します
'https://codezine.jp/article/detail/73

Option Explicit

Private Const LEVEL = 3         '再帰ﾚﾍﾞﾙ

Dim mPnts As Object             'Get_KochCurvePos用座標郡
Dim mDoc As PartDocument
Dim mPt As Part
Dim mFact As HybridShapeFactory

'定数代わり
Dim m1_3 As Double              '1/3
Dim m1_Sq3 As Double            '1/sqr(3)
Dim mPI_6 As Double             'PAI/6 = 30deg

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '初期設定
    m1_3 = 1 / 3
    m1_Sq3 = 1 / Sqr(3)
    mPI_6 = Atn(1) * 4 / 6
    
    Set mDoc = CATIA.ActiveDocument
    Set mPt = mDoc.Part
    Set mFact = mPt.HybridShapeFactory
    
    '頂点座標
    Dim p1, p2, p3
    p1 = Array(100#, 160#)
    p2 = Array(400#, 160#)
    p3 = Array(250#, 420#)
    
    '座標値取得
    Set mPnts = KCL.InitLst()
    mPnts.Add p1
    
    Call Get_KochCurvePos(p1, p2, LEVEL)
    Call Get_KochCurvePos(p2, p3, LEVEL)
    Call Get_KochCurvePos(p3, p1, LEVEL)
    
    '座標値→点ﾘﾌｧﾚﾝｽ
    Dim Refs As Object
    Set Refs = Get_PointRefs(mPnts)
    
    '折れ線化
    Dim Poly  As HybridShapePolyline
    Set Poly = Init_Poly(Refs)
    
    '形状ｾｯﾄへ挿入
    Dim Hbdy As HybridBody
    Set Hbdy = mPt.hybridBodies.Add()
    Hbdy.Name = "Koch_Curve"
    
    Hbdy.AppendHybridShape Poly
    
    'Refsの最後の点のみ不要
    mFact.DeleteObjectForDatum Refs(Refs.Count - 1)
    
    '終わり
    MsgBox "Done"
End Sub

'ﾘﾌｧﾚﾝｽﾘｽﾄから折れ線生成
Private Function Init_Poly(ByVal Refs As Object) As HybridShapePolyline
    Dim Poly As HybridShapePolyline
    Set Poly = mFact.AddNewPolyline()
    
    Dim i As Long
    For i = 0 To Refs.Count - 2
        Poly.InsertElement Refs(i), i
    Next
    Poly.Closure = True
    mPt.UpdateObject Poly
    
    Set Init_Poly = Poly
End Function

'xy座標値郡から点のﾘﾌｧﾚﾝｽﾘｽﾄ生成
Private Function Get_PointRefs(ByVal Lst As Object) As Object
    Dim Refs As Object
    Set Refs = KCL.InitLst
    
    Dim p As Variant
    For Each p In mPnts
        Refs.Add Init_PointRef(p)
    Next
    
    Set Get_PointRefs = Refs
End Function

'xy座標値から点のﾘﾌｧﾚﾝｽ生成
Private Function Init_PointRef(ByVal Ary As Variant) As Reference
    Dim p As HybridShapePointCoord
    Set p = mFact.AddNewPointCoord(Ary(0), Ary(1), 0#)
    mPt.UpdateObject p
    
    Set Init_PointRef = mPt.CreateReferenceFromObject(p)
End Function

'ｺｯﾎ曲線座標
Private Sub Get_KochCurvePos(ByVal p1 As Variant, ByVal p2 As Variant, lv As Long)
    Dim p3 As Variant, p4 As Variant, p5 As Variant
    p3 = Array((2 * p1(0) + p2(0)) * m1_3, (2 * p1(1) + p2(1)) * m1_3)
    p4 = Array((p1(0) + 2 * p2(0)) * m1_3, (p1(1) + 2 * p2(1)) * m1_3)
    
    Dim xx As Double, yy As Double
    xx = p2(0) - p1(0)
    yy = -(p2(1) - p1(1))
    
    Dim dist As Double
    dist = Sqr(xx * xx + yy * yy) * m1_Sq3
    
    Dim ang As Double
    If xx >= 0 Then
        ang = Atn(yy / xx) + mPI_6
        p5 = Array(p1(0) + (dist * Cos(ang)), p1(1) - (dist * Sin(ang)))
    Else
        ang = Atn(yy / xx) - mPI_6
        p5 = Array(p2(0) + (dist * Cos(ang)), p2(1) - (dist * Sin(ang)))
    End If
    
    If lv < 1 Then
        mPnts.Add p3
        mPnts.Add p5
        mPnts.Add p4
        mPnts.Add p2
    Else
        Call Get_KochCurvePos(p1, p3, lv - 1)
        Call Get_KochCurvePos(p3, p5, lv - 1)
        Call Get_KochCurvePos(p5, p4, lv - 1)
        Call Get_KochCurvePos(p4, p2, lv - 1)
    End If
End Sub