曲線と戦ってみる4

ｺｰﾄﾞの理解を深めたかったのと、今後修正等を行いやすくしたかった為
Type1と元に作り直しました。

'vba Arc_Approximated
Option Explicit

Private Const mPntCount = 151&          '曲線上のﾎﾟｲﾝﾄ数
Private Const mIndexMax = mPntCount - 1 '配列用のｲﾝﾃﾞｯｸｽ最大値
Private Const mTole = 0.02              '近似ﾄﾚﾗﾝｽ
Dim mPnts As Variant                    '曲線上の点
Dim mPoss As Variant                    '曲線上の点の座標値
Dim mArcs() As Variant                  '近似化成功した際の3点のｲﾝﾃﾞｯｸｽ
Dim mArcsCount&                         '近似化成功した数

Sub CATMain()
    'Documentﾁｪｯｸ
    If KCL.IsType_Of_T(CATIA.ActiveDocument, "DrawingDocument") Then
        MsgBox "Part又はProductﾌｧｲﾙを開いてください"
        Exit Sub
    End If
    
    '曲線選択
    Dim Msg$: Msg = "曲線を選択して下さい : ESCｷｰ 終了"
    Dim SelElem As SelectedElement
    Set SelElem = KCL.SelectElement(Msg, Array("HybridShape"))
    If KCL.IsNothing(SelElem) Then Exit Sub
    Dim CurveRef As Reference: Set CurveRef = SelElem.Reference
    
    '各種設定
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(CurveRef, "PartDocument")
    
    '点作成、座標値取得
    mPnts = InitPntsOnCurve(Doc.Part, CurveRef)
    mPoss = GetCoordinatesAry(mPnts)
    
    '近似化
    ReDim mArcs(mIndexMax)
    mArcsCount = 0
    Call ChallengeArc(0, mIndexMax)
    If mArcsCount < 1 Then
        MsgBox "近似化できませんでした"
        '本当は点を削除する必要性アリ
        Exit Sub
    End If
    ReDim Preserve mArcs(mArcsCount - 1)
    
    '点群出力
    Call AddTreePnts(mPnts, Doc.Part, "Points")
    
    '近似生成
    Dim ArcCount&: ArcCount = Init3PntArc(mArcs, Doc.Part, "ConvertArcs")
    
    'end
    MsgBox "円弧を" + CStr(ArcCount) + "個生成"
End Sub


'----- ｻﾎﾟｰﾄ関数 -----
'近似化の生成
'return-形状ｾｯﾄ内の要素数
Private Function Init3PntArc&(ByVal Ary As Variant, ByVal Pt As Part, ByVal HBName As String)
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim Ref(2) As Reference
    Dim Arc() As HybridShapeCircle3Points: ReDim Arc(UBound(Ary))
    Dim i&
    On Error Resume Next
    For i = 0 To UBound(Ary)
        Set Arc(i) = Fact.AddNewCircle3Points(mPnts(Ary(i)(0)), _
                                              mPnts(Ary(i)(1)), _
                                              mPnts(Ary(i)(2)))
        Call Pt.UpdateObject(Arc(i))
        If Not Err.Number = 0 Then
            '演算上OKでもCATIAのﾄﾚﾗﾝｽ上NGとなるﾃﾞｰﾀを除去
            Set Arc(i) = Nothing
            Err.Clear
        End If
    Next
    On Error GoTo 0
    Init3PntArc = AddTreePnts(Arc, Pt, HBName)
End Function

'形状ｾｯﾄに挿入
'return-形状ｾｯﾄ内の要素数
Private Function AddTreePnts&(ByVal Ary As Variant, ByVal Pt As Part, ByVal HBName As String)
    Dim HB As HybridBody: Set HB = Pt.HybridBodies.Add
    HB.Name = HBName
    Dim i&
    For i = 0 To UBound(Ary)
        If Not KCL.IsNothing(Ary(i)) Then
            Call HB.AppendHybridShape(Ary(i))
        End If
    Next
    AddTreePnts = HB.HybridShapes.Count
End Function

'ﾄﾚﾗﾝｽ以内に近似化可能な3点のｲﾝﾃﾞｯｸｽ郡を取得 - 再帰
Private Sub ChallengeArc(ByVal StIdx&, ByVal EndIdx&)
    If 2 > (EndIdx - StIdx) Then
        Exit Sub
    End If
    Dim MidIdx&: MidIdx = Int((StIdx + EndIdx) * 0.5)
    Dim Arc As Variant
    Arc = GetCircumCircleOfTriangle(mPoss(StIdx), mPoss(MidIdx), mPoss(EndIdx))
    If Not IsEmpty(Arc) Then
        If CheckTolerance(KCL.GetRangeAry(mPoss, StIdx + 1, EndIdx - 1), Arc) Then
            'OK
            mArcs(mArcsCount) = Array(StIdx, MidIdx, EndIdx)
            mArcsCount = mArcsCount + 1
            Exit Sub
        End If
    End If
    'NG
    Call ChallengeArc(StIdx, MidIdx)
    Call ChallengeArc(MidIdx, EndIdx)
End Sub

'座標値郡が円弧のﾄﾚﾗﾝｽ以内に有るかﾁｪｯｸ
'GetCircumCircleOfTriangle関数の戻り値を使用すること
Private Function CheckTolerance(ByVal Ary As Variant, ByVal Arc As Variant) As Boolean
    Dim i&
    For i = 0 To UBound(Ary)
        If mTole < Math.Abs(Arc(1) - GetDist(Ary(i), Arc(0))) Then
            CheckTolerance = False
            Exit Function
        End If
    Next
    CheckTolerance = True
End Function

'点群より座標値郡取得
Private Function GetCoordinatesAry(ByVal Pnts As Variant) As Variant
    Dim Poss() As Variant: ReDim Poss(mIndexMax)
    Dim P(2) As Variant, i&
    For i = 0 To mIndexMax
        Call Pnts(i).GetCoordinates(P)
        Poss(i) = P
    Next
    GetCoordinatesAry = Poss
End Function

'曲線上の点群作成
Private Function InitPntsOnCurve(ByVal Pt As Part, ByVal CurveRef As Reference) As Variant
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim Pnts() As Variant: ReDim Pnts(mIndexMax)
    Dim i&, Ratio#, Pnt As HybridShapePointOnCurve
    For i = 0 To mIndexMax
        Ratio = i / mIndexMax
        Set Pnts(i) = Fact.AddNewPointOnCurveFromPercent(CurveRef, Ratio, False)
        Call Pt.UpdateObject(Pnts(i))
    Next
    InitPntsOnCurve = Pnts
End Function



'----- 演算関連 -----
'三角形の外接円の取得(3点通過円)
'return:array(0)-外心(array(2))
'       array(1)-半径
Private Function GetCircumCircleOfTriangle(ByVal P1 As Variant, _
                                           ByVal P2 As Variant, _
                                           ByVal P3 As Variant) As Variant
    Dim M1 As Variant: M1 = GetMidPnt(P1, P2)
    Dim M2 As Variant: M2 = GetMidPnt(P2, P3)
    
    Dim V1 As Variant: V1 = Normalize(ToVecter(P1, P2))
    Dim V2 As Variant: V2 = Normalize(ToVecter(P2, P3))
    
    Dim EulerLineVec As Variant 'V2の直交ﾍﾞｸﾄﾙ 元n2
    EulerLineVec = Normalize(Cross(V2, Cross(V1, V2)))
    
    '3点が直線上に存在している場合、除去
    Dim nv#: nv = Dot(V1, EulerLineVec)
    If GetDistSquare(ZeroVec, EulerLineVec) < 0.001 Then Exit Function
    If Math.Abs(nv) < 0.001 Then Exit Function 'ｵﾘｼﾞﾅﾙは過剰な精度な為値を修正
    
    'これが何に該当するのか不明 M2から外心までの距離？
    Dim t#: t = (Dot(V1, M1) - Dot(V1, M2)) / nv
    
    '外心取得
    Dim Center As Variant
    Center = GetCircumCenter(M2, EulerLineVec, t)
    
    '半径取得
    Dim Radius As Double
    Radius = GetDist(Center, P1)
    
    '外接円
    Dim CCofT(1) As Variant
    CCofT(0) = Center
    CCofT(1) = Radius
    GetCircumCircleOfTriangle = CCofT
End Function

'2点の中間点
Private Function GetMidPnt(ByVal P1 As Variant, ByVal P2 As Variant) As Variant
    Dim Pnt(2) As Double, i&
    For i = 0 To UBound(Pnt)
        Pnt(i) = (P1(i) + P2(i)) * 0.5
    Next
    GetMidPnt = Pnt
End Function

'外心の取得
Private Function GetCircumCenter(ByVal P As Variant, _
                                 ByVal V As Variant, _
                                 ByVal L As Double) As Variant
    Dim cc(2) As Double, i&
    For i = 0 To UBound(cc)
        cc(i) = P(i) + V(i) * L
    Next
    GetCircumCenter = cc
End Function

'2点間距離-平方数
Private Function GetDistSquare(ByVal P1 As Variant, ByVal P2 As Variant) As Double
    GetDistSquare = (P2(0) - P1(0)) * (P2(0) - P1(0)) + _
                    (P2(1) - P1(1)) * (P2(1) - P1(1)) + _
                    (P2(2) - P1(2)) * (P2(2) - P1(2))
End Function

'2点間距離
Private Function GetDist(ByVal P1 As Variant, ByVal P2 As Variant) As Double
    GetDist = Math.Sqr(GetDistSquare(P1, P2))
End Function


'----- ﾍﾞｸﾄﾙ関連 -----
'内積3D
Private Function Dot(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Dot = V1(0) * V2(0) + V1(1) * V2(1) + V1(2) * V2(2)
End Function

'外積3D
Private Function Cross(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Dim Vec(2) As Double
    Vec(0) = V1(1) * V2(2) - V1(2) * V2(1)
    Vec(1) = V1(2) * V2(0) - V1(0) * V2(2)
    Vec(2) = V1(0) * V2(1) - V1(1) * V2(0)
    Cross = Vec
End Function

'単位ﾍﾞｸﾄﾙ化
Private Function Normalize(ByVal V1 As Variant) As Variant
    Dim L As Double: L = GetDist(ZeroVec, V1)
    If L < 0.00001 Then
        Normalize = ZeroVec
        Exit Function
    End If
    Dim Nml(2) As Double, i&
    For i = 0 To UBound(Nml)
        Nml(i) = V1(i) / L
    Next
    Normalize = Nml
End Function

'2点間ﾍﾞｸﾄﾙ
Private Function ToVecter(ByVal P1 As Variant, ByVal P2 As Variant) As Variant
    Dim Vec(2) As Double, i&
    For i = 0 To UBound(Vec)
        Vec(i) = P2(i) - P1(i)
    Next
    ToVecter = Vec
End Function

'ｾﾞﾛﾍﾞｸﾄﾙ
Private Function ZeroVec() As Variant
    ZeroVec = Array(0#, 0#, 0#)
End Function

ほぼ同等な処理になっていると思いますが、相変わらずｺｰﾄﾞ倍増です。
又、このｺｰﾄﾞのみでは実行できません。
同一プロジェクト内に "KCL" と言う名称の標準ﾓｼﾞｭｰﾙを
用意していただき、こちらのｺｰﾄﾞをｺﾋﾟﾍﾟしﾗｲﾌﾞﾗﾘとして
用意して頂く必要があります。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA

念の為ﾃｽﾄ画像を。こちらは3Dな曲線です。
f:id:kandennti:20160621144833p:plain