単独な3D曲線の取得する1

こちらの続きです。
端点一致を探る、組み合わせテスト5 - C#ATIA

とりあえず、機能するものを先に作りました。

'vba test_FindSingle3DCurve Ver0.0.1  using-'KCL0.08'
'単独な3D曲線の取得
Option Explicit

'*** 設定 ***
Private Const Tolerance = 0.001                         '端点一致ﾄﾚﾗﾝｽ
Private Const SingleCurveFooter = " - SingleCurve!!"    '単独曲線名に追記する文字
'************

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub
    Dim msg$
    
    '形状ｾｯﾄの選択
    msg = "3D曲線の入っている形状ｾｯﾄを指定してください : ESCｷｰ 終了"
    Dim Hb As HybridBody
    Set Hb = KCL.SelectItem(msg, "HybridBody")
    If KCL.IsNothing(Hb) Then Exit Sub
    
    '線の取得
    Dim Lines As Collection: Set Lines = GetLines(Hb)
    If KCL.IsNothing(Lines) Then
        msg = "指定した' " + Hb.Name + " 'には、3D曲線がありませんでした!"
        MsgBox msg
        Exit Sub
    End If
    
    '警告
    If Lines.Count > 200 Then
        msg = CStr(Lines.Count) + "本で実行すると、それなりに時間がかかりますが、実行しますか?"
        If MsgBox(msg, vbYesNo + vbInformation) = vbNo Then Exit Sub
    End If
    
    '端点座標取得
    Dim EndPnts As Collection: Set EndPnts = GetEndPntCoordinates(Lines)
    
    '単独曲線ｲﾝﾃﾞｯｸｽ取得
    Dim SingleList As Collection: Set SingleList = GetSingleIdx(EndPnts)
    If SingleList.Count < 1 Then
        msg = "指定した' " + Hb.Name + " 'には、単独な3D曲線が見つかりませんでした!" + vbNewLine + _
              "(ﾄﾚﾗﾝｽ " & Tolerance & " mm)"
        MsgBox msg
        Exit Sub
    End If
    
    '確認
    msg = SingleList.Count & "本の単独な3D曲線が見つかりました!!" + vbNewLine + _
          "名前の最後に ' " + SingleCurveFooter + " ' を追記しますか?"
    If MsgBox(msg, vbYesNo + vbInformation) = vbNo Then Exit Sub
    
    'ﾘﾈｰﾑ
    Call AppendName(Lines, SingleList)
    
    MsgBox "終了!"
End Sub

'単独曲線のﾘﾈｰﾑ
Private Sub AppendName(ByVal Lines As Collection, ByVal IdxList As Collection)
    Dim i
    For Each i In IdxList
        With Lines.Item(i)
            .Name = .Name & SingleCurveFooter
        End With
    Next
End Sub

'初期化済み配列生成 - ｵﾌﾞｼﾞｪｸﾄNG
Private Function InitRangeAry(ByVal Count&, ByVal Value As Variant)
    Dim ary() As Variant: ReDim ary(Count)
    Dim i&
    For i = 0 To Count
        ary(i) = Value
    Next
    InitRangeAry = ary
End Function

'単独曲線ｲﾝﾃﾞｯｸｽ取得
Private Function GetSingleIdx(ByVal EndPnts As Collection) As Collection
    Dim i&, j&
    Dim CombAry As Variant: CombAry = InitRangeAry(EndPnts.Count * 0.5, False)
    For i = 1 To EndPnts.Count
        For j = i + 1 To EndPnts.Count
            If EndPnts.Item(i)(1) = EndPnts.Item(j)(1) Then GoTo Continue
            
            If IsPosEqual(EndPnts.Item(i)(0), EndPnts.Item(j)(0)) Then
                CombAry(EndPnts.Item(i)(1)) = True
                CombAry(EndPnts.Item(j)(1)) = True
            End If
Continue:
        Next
    Next
    Dim SingleIdxList As Collection: Set SingleIdxList = New Collection
    For i = 1 To UBound(CombAry)
        If CombAry(i) = False Then SingleIdxList.add i
    Next
    Set GetSingleIdx = SingleIdxList
End Function

'座標値一致
Private Function IsPosEqual(ByVal p1 As Variant, ByVal p2 As Variant) As Boolean
    IsPosEqual = False
    Dim i&
    For i = 0 To 2
        If Abs(p2(i) - p1(i)) > Tolerance Then Exit Function
    Next
    If Sqr(Abs((p2(0) - p1(0)) * (p2(0) - p1(0)) + _
               (p2(1) - p1(1)) * (p2(1) - p1(1)) + _
               (p2(2) - p1(2)) * (p2(2) - p1(2)))) < Tolerance Then
        IsPosEqual = True
    End If
End Function

'端点取得
Private Function GetEndPntCoordinates(ByRef Lines As Collection) As Collection
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(Lines.Item(1), "PartDocument")
    Dim SPAWB As Workbench: Set SPAWB = Doc.GetWorkbench("SPAWorkbench")
    Dim EndPnt As Collection: Set EndPnt = New Collection
    Dim Pos(8) As Variant
    Dim i&
    For i = 1 To Lines.Count
        Call SPAWB.GetMeasurable(Lines.Item(i)).GetPointsOnCurve(Pos)
        EndPnt.add Array(KCL.GetRangeAry(Pos, 0, 2), i)
        EndPnt.add Array(KCL.GetRangeAry(Pos, 6, 8), i)
    Next
    Set GetEndPntCoordinates = EndPnt
End Function

'線取得
Private Function GetLines(ByVal Hb As HybridBody) As Collection
    Dim Hss As HybridShapes: Set Hss = Hb.HybridShapes
    If Hss.Count < 1 Then Exit Function
    
    Dim Pt As Part: Set Pt = KCL.GetParent_Of_T(Hb, "PartDocument").Part
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim Lines As Collection: Set Lines = New Collection
    Dim Hs As HybridShape
    For Each Hs In Hss
        Select Case Fact.GetGeometricalFeatureType(Hs)
            Case 2, 3, 4
                Lines.add Hs
        End Select
    Next
    Set GetLines = Lines
End Function

8分木が未だに解決しない為、総当りのﾀﾞﾒなやつです。
ﾃｽﾄしたところ250本強の曲線で3.5秒程でした。

わかりにくいので、ご説明を。

ﾏｸﾛ実行後、該当する形状ｾｯﾄを指定します。　上記の様な状態の場合
"形状ｾｯﾄ.1" を選択した場合は、曲線が無い為ﾏｸﾛを中止します。
あくまで指定した形状ｾｯﾄ内の曲線のみで処理される為、このような
場合は "形状ｾｯﾄ.2" を指定してください。
又、非表示されている曲線も評価対象となっています。

実行し単独曲線を発見した場合は、このようなﾀﾞｲｱﾛｸﾞが出ます。
"はい" を選択すれば、曲線名にﾒｯｾｰｼﾞの文字を追記します。

こんな感じです。

端点が一致しているようにも見えますが、ﾄﾚﾗﾝｽ以上の距離に
なっている為、単独曲線と判断されています。
･･･Space-eのｻｰﾌｪｽﾃﾞｰﾀから、境界を抽出したものをｻﾝﾌﾟﾙとして
試しているのですが、隙間だらけって事です。　困っちゃう。

あくまで端点同士の一致を見ているため

ｵﾚﾝｼﾞ色と水色の曲線は一致している為、単独な曲線とは判断されませんが
ｵﾚﾝｼﾞ色と黄色の曲線は一致していない(黄色の端点ではない)為、
黄色の曲線は単独曲線と判断されます。

8分木何とかしたい。