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

明けましておめでとうございます。 ﾏｲﾍﾟｰｽでやっていきます。
こちらの続きです。
単独な3D曲線の取得する2 - C#ATIA

昨年末に線形8分木を実装しましたが、若干効率が悪いことには
気が付いていた為、処理効率を上げるように修正してみました。

CATMainを持つ標準ﾓｼﾞｭｰﾙ "FindSingle3DCurve.bas" です。

'vba FindSingle3DCurve Ver0.0.3  using-'KCL0.09' 'FindSingle3DCurve_Octree0.0.3'
'単独な3D曲線の取得

Option Explicit

'*** 設定 ***
Private Const Tolerance = 0.001                         '端点一致ﾄﾚﾗﾝｽ
Private Const InSpaceMaxCount = 200&                    '同一空間内最大数(目安)
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
    
    '警告
    Msg = CStr(Lines.Count) + "本あります。実行しますか?"
    
    If MsgBox(Msg, vbYesNo + vbInformation) = vbNo Then Exit Sub
    Debug.Print "** start003 ** : " + CStr(Lines.Count) + "本" 'debug
    Debug.Print "InSpaceMaxCount : " + CStr(InSpaceMaxCount) 'debug
    KCL.SW_Start 'debug
    
    '端点座標取得
    Dim EndPnts As Collection: Set EndPnts = GetEndPntCoordinates(Lines)
    Debug.Print "EndPnts : " + CStr(KCL.SW_GetTime) 'debug
    
    '組み合わせﾘｽﾄ取得
    Dim OctList As Collection
    Set OctList = FindSingle3DCurve_Octree.GetLinerOctreeList(EndPnts, Tolerance, InSpaceMaxCount)
    If KCL.IsNothing(OctList) Then
        Msg = "ｴﾗｰです。ﾏｸﾛ内の設定値を修正して下さい(特に 'OctLv' )"
        MsgBox Msg: Exit Sub
    End If
    Debug.Print "OctList : " + CStr(KCL.SW_GetTime) 'debug
    
    '単独曲線ｲﾝﾃﾞｯｸｽ取得
    Dim SingleList As Collection: Set SingleList = GetSingleIdx(EndPnts, OctList)
    Debug.Print "SingleList : " + CStr(SingleList.Count) + " : " + CStr(KCL.SW_GetTime)
    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 GoTo MacroEnd
    
    'ﾘﾈｰﾑ
    Call AppendName(Lines, SingleList)
    
MacroEnd:
    'Call Dump(ByVal SingleList, ByVal Lines, ByVal EndPnts) 'debug
    'Call DumpCount(ByVal OctList) 'debug
    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

'単独曲線端点とそうではない端点を分ける
''' @return:Collection(Collection-一致,Collection-未確定)
Private Function GroupBySinglePointList(ByVal PntList As Collection, _
                                        ByVal EndPnts As Collection, _
                                        ByVal CombAry) As Variant
    Dim TrueList As Collection: Set TrueList = New Collection
    Dim FalseList As Collection: Set FalseList = New Collection
    Dim Idx
    For Each Idx In PntList
        If CombAry(EndPnts.Item(Idx)(3)) Then
            TrueList.Add Idx
        Else
            FalseList.Add Idx
        End If
    Next
    GroupBySinglePointList = Array(TrueList, FalseList)
End Function

'単独曲線ｲﾝﾃﾞｯｸｽ取得
Private Function GetSingleIdx(ByVal EndPnts As Collection, ByVal OctList As Collection) As Collection
    Dim i&, j&, i_crv_idx, j_crv_idx
    Dim CombAry As Variant: CombAry = InitRangeAry(EndPnts.Count * 0.5, False)
    Dim Space As Collection
    Dim GroupAry, TrueList As Collection, FalseList As Collection
    
    For Each Space In OctList
        '未確定同士
        GroupAry = GroupBySinglePointList(Space, EndPnts, CombAry)
        Set TrueList = GroupAry(0)
        Set FalseList = GroupAry(1)
        For i = 1 To FalseList.Count
            i_crv_idx = EndPnts.Item(FalseList.Item(i))(3)
            For j = i + 1 To FalseList.Count
                j_crv_idx = EndPnts.Item(FalseList.Item(j))(3)
                If i_crv_idx = j_crv_idx Then GoTo Continue1
                If CombAry(i_crv_idx) And CombAry(j_crv_idx) Then GoTo Continue1
                If IsPosEqual(EndPnts.Item(FalseList.Item(i)), EndPnts.Item(FalseList.Item(j))) Then
                    CombAry(i_crv_idx) = True
                    CombAry(j_crv_idx) = True
                End If
Continue1:
            Next
        Next
        
        '未確定-確定
        GroupAry = GroupBySinglePointList(FalseList, EndPnts, CombAry)
        Set FalseList = GroupAry(1)
        For i = 1 To FalseList.Count
            i_crv_idx = EndPnts.Item(FalseList.Item(i))(3)
            For j = 1 To TrueList.Count
                j_crv_idx = EndPnts.Item(TrueList.Item(j))(3)
                If i_crv_idx = j_crv_idx Then GoTo Continue2
                If CombAry(i_crv_idx) And CombAry(j_crv_idx) Then GoTo Continue2
                If IsPosEqual(EndPnts.Item(FalseList.Item(i)), EndPnts.Item(TrueList.Item(j))) Then
                    CombAry(i_crv_idx) = True
                End If
Continue2:
            Next
        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 KCL.JoinAry(KCL.GetRangeAry(Pos, 0, 2), Array(i))
        EndPnt.Add KCL.JoinAry(KCL.GetRangeAry(Pos, 6, 8), Array(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

'debug用
Private Sub Dump(ByVal SingleList, ByVal Lines, ByVal EndPnts)
    Dim ss
    For Each ss In SingleList
        Debug.Print ss & ":" & Lines.Item(EndPnts.Item(ss)(3)).Name
    Next
End Sub

'debug用
Private Sub DumpCount(ByVal List)
    Dim ss
    For Each ss In List
        Debug.Print ss.Count
    Next
End Sub

'ver0.0.1 - 総当りのﾀﾞﾒなやつ
'ver0.0.2 - 線形8分木を実装
'ver0.0.3 - 端点一致ｱﾙｺﾞﾘｽﾞﾑ効率化

続いて、組み合わせﾘｽﾄを作り出す "FindSingle3DCurve_Octree.bas" です。

'vba FindSingle3DCurve_Octree Ver0.0.3  using-'KCL0.09'
'ﾓｰﾄﾝ順序を利用した8分木空間分割ﾗｲﾌﾞﾗﾘ
'FindSingle3DCurveﾏｸﾛ専用です

Option Explicit

Private Const CLINER8TREEMANAGER_MAXLEVEL = 7   '有効空間分割最大ﾚﾍﾞﾙ

Private m_Level&                                '分割ﾚﾍﾞﾙ
Private m_Tolerance#                            '一致ﾄﾚﾗﾝｽ
Private m_MaxCount&                             '同一空間内最大数(目安)
Private m_AxisCount&                            '空間分割時の各軸の最大数
Private m_MinPos                                '空間最小座標
Private m_Unit                                  '空間単位ｻｲｽﾞ
Private m_ToleranceRatio                        '空間単位ｻｲｽﾞに対してのﾄﾚﾗﾝｽ比率
Private m_CellCount&()                          'ﾚﾍﾞﾙ毎の空間数

'*** Octree ***
'http://marupeke296.com/COL_3D_No15_Octree.html

'線形8分木ﾘｽﾄ取得
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Collection(Collection(long))-空間別点Idx郡
Function GetLinerOctreeList(ByVal Pnts As Collection, ByVal Tolerance#, ByVal MaxCount&)
    Set GetLinerOctreeList = Nothing
    
    '座標値郡のIdxList作成
    Dim PntIdxList As Collection: Set PntIdxList = InitRangeList(Pnts.Count)
    
    '空間内最大数以下の場合、そのまま返す
    Dim DecidedList As Collection: Set DecidedList = New Collection
    If Pnts.Count < MaxCount Then
        Call DecidedList.Add(PntIdxList)
        GoTo FuncEnd
    End If
    
    '初期設定
    If Not SetStart(Tolerance, MaxCount) Then
        MsgBox "設定値が不正です"
        Exit Function
    End If
    
    'IdxListをﾙｰﾄ空間として登録
    Dim CheckList As Collection: Set CheckList = New Collection
    Call CheckList.Add(PntIdxList)
    
    'ﾚﾍﾞﾙの応じたIdx用配列
    Dim SpeceEnum, TempList As Collection, ReCheckList As Collection
    Dim Space, TempSpace, SpaAry, i&, Idx
    Do
        Set ReCheckList = New Collection
        '配置
        For Each Space In CheckList
            If Not SetSpaceInfo(Pnts, Space) Then '空間が小さすぎる
                Call DecidedList.Add(Space)
                GoTo Continue
            End If
            
            SpeceEnum = InitRangeAry(m_CellCount(m_Level), -1)
            Set TempList = New Collection
            
            For Each Idx In Space
                SpaAry = GetMortonNum(Pnts(Idx))
                For i = 0 To UBound(SpaAry)
                    If SpeceEnum(SpaAry(i)) < 0 Then
                        Call TempList.Add(InitSpace())
                        SpeceEnum(SpaAry(i)) = TempList.Count
                    End If
                    Call TempList.Item(SpeceEnum(SpaAry(i))).Add(Idx)
                Next
            Next
            
            '空間毎の数が多いものを再配置
            For Each TempSpace In TempList
                Select Case True
                    Case TempSpace.Count < 2
                        '空間に1個しかないものは検証しない
                        'Call DecidedList.add(TempSpace)
                    Case TempSpace.Count > m_MaxCount
                        Call ReCheckList.Add(TempSpace)
                    Case Else
                        Call DecidedList.Add(TempSpace)
                End Select
            Next
Continue:
        Next
        If ReCheckList.Count < 1 Then Exit Do
        Set CheckList = ReCheckList
    Loop
    
FuncEnd:
    Call Q_ISort_List(DecidedList)
    Set GetLinerOctreeList = DecidedList
    Set PntIdxList = Nothing
    Set DecidedList = Nothing
    Set CheckList = Nothing
    Set ReCheckList = Nothing
    Set TempList = Nothing
    ReDim SpeceEnum(0)
End Function

'空のｺﾚｸｼｮﾝ
Private Function InitSpace() As Collection
    Set InitSpace = New Collection
End Function

'線形8分木準備
''' @param :Level-long-分割ﾚﾍﾞﾙ
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Boolean
Private Function SetStart(ByVal Tolerance#, ByVal MaxCount&) As Boolean
    SetStart = False
    If Tolerance <= 0 Then Exit Function
    
    m_Tolerance = Tolerance
    m_MaxCount = MaxCount
    m_ToleranceRatio = InitRangeAry(2, 0)
    
    ReDim m_CellCount(CLINER8TREEMANAGER_MAXLEVEL + 1)
    m_CellCount(0) = 1
    Dim i&
    For i = 1 To UBound(m_CellCount)
        m_CellCount(i) = m_CellCount(i - 1) * 8
    Next
    SetStart = True
End Function

'空間ｻｲｽﾞとﾄﾚﾗﾝｽからﾚﾍﾞﾙ算出し設定
Private Function SetLevel(ByVal W) As Boolean
    SetLevel = False
    Dim Min#: Min = 1.79769313486231E+308
    Dim i&
    For i = 0 To 2
         If Min > W(i) Then Min = W(i)
    Next
    Dim TmpLv&: TmpLv = Fix(Log_n((Min / (m_Tolerance * 2 + 0.002)), 2))
    If TmpLv > CLINER8TREEMANAGER_MAXLEVEL Then
        m_Level = CLINER8TREEMANAGER_MAXLEVEL
    Else
        m_Level = TmpLv
    End If
    
    If m_Level < 1 Then Exit Function
    m_AxisCount = sl(1, m_Level)
    SetLevel = True
End Function

'空間情報設定
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Idxs-Collection(long)-座標値郡Idx
''' @return:Boolean
Private Function SetSpaceInfo(ByVal Pnts, ByVal Idxs As Collection) As Boolean
    SetSpaceInfo = False
    Dim SpSize: SpSize = GetSpaceSize_Idx(Pnts, Idxs)
    m_MinPos = AryAdd(SpSize(0), m_Tolerance * -1)
    Dim W: W = ArySub(AryAdd(SpSize(1), m_Tolerance), m_MinPos)
    If Not SetLevel(W) Then Exit Function
    m_Unit = AryDiv(W, m_AxisCount)
    
    Dim i&
    For i = 0 To 2
        m_ToleranceRatio(i) = m_ToleranceRatio(i) / m_Unit(i)
    Next
    SetSpaceInfo = True
End Function

'座標→最小ﾚﾍﾞﾙ空間番号郡取得
''' @param :Pos-array(Double)-座標値
''' @return:array(Long)
Private Function GetMortonNum(ByVal Pos As Variant) As Variant
    Dim Ratio#(2), Inte&(2), Dec#(2)
    Dim i&
    For i = 0 To 2
        Ratio(i) = (Pos(i) - m_MinPos(i)) / m_Unit(i)
        Inte(i) = Fix(Ratio(i))
        Dec(i) = Ratio(i) - Inte(i)
    Next
    
    Dim Axis(2) As Variant
    Dim AxisNums As Collection
    For i = 0 To 2
        Set AxisNums = New Collection
        AxisNums.Add Inte(i)
        If Dec(i) <= m_ToleranceRatio(i) And Inte(i) > 0 Then AxisNums.Add Inte(i) - 1
        If 1# - Dec(i) <= m_ToleranceRatio(i) And Inte(i) < m_AxisCount - 1 Then AxisNums.Add Inte(i) + 1
        Set Axis(i) = AxisNums
    Next
    
    Dim x, y, z
    Dim SpaNo(): ReDim SpaNo(Axis(0).Count * Axis(1).Count * Axis(2).Count)
    Dim cnt&: cnt = -1
    For Each x In Axis(0)
        For Each y In Axis(1)
            For Each z In Axis(2)
                cnt = cnt + 1
                SpaNo(cnt) = Get3DMortonNumber(x, y, z)
                If SpaNo(cnt) < 0 And SpaNo(cnt) >= m_CellCount(m_Level) Then cnt = cnt - 1
    Next: Next: Next
    ReDim Preserve SpaNo(cnt)
    GetMortonNum = SpaNo
End Function

'ビット分割関数
''' @param :n-long
''' @return:long
Private Function BitSeparateFor3D(ByVal n&) As Long
    Dim s As Long: s = n
    s = (s Or sl(s, 8)) And &HF00F
    s = (s Or sl(s, 4)) And &HC30C3
    s = (s Or sl(s, 2)) And &H249249
    BitSeparateFor3D = s
End Function

'8分木モートン順序算出関数
''' @param :x-long
''' @param :y-long
''' @param :z-long
''' @return:long
Private Function Get3DMortonNumber(ByVal x&, ByVal y&, ByVal z&) As Long
   Get3DMortonNumber = BitSeparateFor3D(x) Or _
                       sl(BitSeparateFor3D(y), 1) Or _
                       sl(BitSeparateFor3D(z), 2)
End Function

'座標値郡から空間ｻｲｽﾞ取得
''' @param :EndPnts-Collection(array(Double))-座標値郡
''' @return:array(array(Double))-0:最小値 1:最大値
Private Function GetSpaceSize_Idx(ByVal EndPnts As Collection, ByVal IdxList As Collection) As Variant
    Dim Min: Min = InitRangeAry(2, 1.79769313486231E+308)
    Dim Max: Max = InitRangeAry(2, -1.79769313486231E+308)
    
    Dim Idx, i&
    For Each Idx In IdxList
        For i = 0 To 2
            If Min(i) > EndPnts.Item(Idx)(i) Then Min(i) = EndPnts.Item(Idx)(i)
            If Max(i) < EndPnts.Item(Idx)(i) Then Max(i) = EndPnts.Item(Idx)(i)
        Next
    Next
    GetSpaceSize_Idx = Array(Min, Max)
End Function

'*** BitShift ***
'http://www.geocities.co.jp/SiliconValley/4334/unibon/asp/bitshift2.html
' 左シフト
Private Function sl(ByVal x&, ByVal n&) As Long
    If n = 0 Then
        sl = x
    Else
        Dim k: k = CLng(2 ^ (32 - n - 1))
        Dim d: d = x And (k - 1)
        Dim c: c = d * CLng(2 ^ n)
        If x And k Then c = c Or &H80000000
        sl = c
    End If
End Function

'*** VBA不足関数 ***
'配列同士の引き算-細かいチェック無し
Private Function ArySub(ByVal A, ByVal B) As Variant
    ArySub = Array(A(0) - B(0), A(1) - B(1), A(2) - B(2))
End Function

'配列と実数の足し算-細かいチェック無し
Private Function AryAdd(ByVal A, ByVal B#) As Variant
    AryAdd = Array(A(0) + B, A(1) + B, A(2) + B)
End Function

'配列と実数の割り算-細かいチェック無し
Private Function AryDiv(ByVal A, ByVal B#) As Variant
    AryDiv = Array(A(0) / B, A(1) / B, A(2) / B)
End Function

'初期化済み配列生成 - ｵﾌﾞｼﾞｪｸﾄ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 InitRangeList(ByVal Count&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = 1 To Count
        List.Add i
    Next
    Set InitRangeList = List
End Function

'ｺﾚｸｼｮﾝｶｳﾝﾀによるｸｲｯｸｿｰﾄ　非再帰版
Private Sub Q_ISort_List(ByRef List As Collection)
    Dim Threashold&: Threashold = 64
    Dim Stack As Collection: Set Stack = New Collection
    Stack.Add 1, CStr(Stack.Count + 1)
    Stack.Add List.Count, CStr(Stack.Count + 1)
    
    Dim Pivot, Temp1, Temp2
    Dim LeftIdx&, RightIdx&, i&, j&
    Do While Stack.Count > 0
        LeftIdx = Stack(CStr(Stack.Count - 1))
        RightIdx = Stack(CStr(Stack.Count))
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        'クイックソート
        If LeftIdx < RightIdx Then
            Set Pivot = List((LeftIdx + RightIdx) / 2)
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While List(i).Count < Pivot.Count
                    i = i + 1
                Loop
                Do While List(j).Count > Pivot.Count
                    j = j - 1
                Loop
                If i <= j Then
                    Set Temp1 = List(i)
                    Set Temp2 = List(j)
                    List.Add Temp1, After:=j
                    List.Remove j
                    List.Add Temp2, After:=i
                    List.Remove i
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 0 Then
                If RightIdx - i <= Threashold Then
                    ComboInsertionSort List, i, RightIdx
                Else
                    Stack.Add i, CStr(Stack.Count + 1)
                    Stack.Add RightIdx, CStr(Stack.Count + 1)
                End If
            End If
            
            If j - LeftIdx >= 0 Then
                If j - LeftIdx <= Threashold Then
                    ComboInsertionSort List, LeftIdx, j
                Else
                    Stack.Add LeftIdx, CStr(Stack.Count + 1)
                    Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
    Loop
End Sub

'InsertSort
Private Sub ComboInsertionSort(ByRef List, ByVal MinIdx&, ByVal MaxIdx&)
    Dim Temp1, Temp2
    Dim i&, j&: j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
            If List(i + 1).Count < List(i).Count Then
                Set Temp1 = List(i + 1)
                Set Temp2 = List(i)
                List.Add Temp2, After:=i + 1
                List.Remove i + 1
                List.Add Temp1, After:=i
                List.Remove i
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

'nを底とする対数
Private Function Log_n(x, n)
    Log_n = Log(x) / Log(n)
End Function

'ver0.0.1 - とりあえず完成
'ver0.0.3 - 分割ﾚﾍﾞﾙ自動化,線形8分木ｿｰﾄ化

細々した事を書いても仕方ない為説明を割愛しますが、Ver0.0.2の際は
線形8分木ﾘｽﾄを取得する際、事前にInit関数を利用し分割ﾚﾍﾞﾙを指定する
必要がありましたが、与えられたﾃﾞｰﾀ(端点座標値郡)と一致ﾄﾚﾗﾝｽから
自動的に可能な限り深いﾚﾍﾞﾙまで分割するようにしました。
(そもそもｲﾝｽﾀﾝｽを作成しないのに、" Init " と言う名称の関数がある事
自体おかしかったです…)

Ver0.0.2と0.0.3を比べた結果はこちらです。

Ver0.0.2
** start ** : 4100本
OctLv : 7  InSpaceMaxCount : 200
EndPnts : 2.214
OctList : 3.33
SingleList : 1 : 4.128

Ver0.0.3
** start003 ** : 4100本
InSpaceMaxCount : 200
EndPnts : 1.794
OctList : 3.103
SingleList : 1 : 3.909

Ver0.0.2
** start ** : 8200本
OctLv : 7  InSpaceMaxCount : 200
EndPnts : 3.836
OctList : 7.519
SingleList : 2 : 10.692

Ver0.0.3
** start003 ** : 8200本
InSpaceMaxCount : 200
EndPnts : 4.359
OctList : 8.764
SingleList : 2 : 11.909

Ver0.0.2
** start ** : 12300本
OctLv : 7  InSpaceMaxCount : 200
EndPnts : 6.409
OctList : 14.139
SingleList : 3 : 21.447

Ver0.0.3
** start003 ** : 12300本
InSpaceMaxCount : 200
EndPnts : 6.472
OctList : 15.635
SingleList : 3 : 22.646

逆に1秒程遅くなっちゃいましたね･･･。

もう少し効率を上げられそうなｱｲﾃﾞｱは幾つかあるのですが、単独な3D曲線を
見つけ出すﾏｸﾛ自体が、恐らくご相談頂いた方以外には需要がほぼ無い気が
するので、この辺で一旦終了にします。

8分木空間分割ﾗｲﾌﾞﾗﾘについては結構悩みながら作ったので、他のﾏｸﾛでも
利用可能なように修正し、こちらのﾏｸﾛ達にも実装すれば処理時間の短縮が
出来そうな気がしています。こちら何かで。
ｻｰﾌｪｽの色をﾎﾞﾃﾞｨに反映する - C#ATIA
二つのﾎﾞﾃﾞｨ/形状ｾｯﾄを比較して、差分を抽出する - C#ATIA
そのうちに…。