2D曲線の折れ線化を利用し、重複線の選択2

こちらの続きです。
2D曲線の折れ線化を利用し、重複線の選択1 - C#ATIA

昨日の4分木ﾗｲﾌﾞﾗﾘを利用して、前回の重複線を選択した状態にする
ﾏｸﾛを改良しました。

'vba test_Select_Overlap_Curve2D ver0.0.2
'using-'KCL0.09' -'KCL_Quadtree0.0.1'
'指定ﾋﾞｭｰ内の重複線を選択

Option Explicit

'*** 設定 ***
Private Const POLY_TOL = 0.1        '折れ線化ﾄﾚﾗﾝｽ
Private Const OVER_TOL = 0.1        '重複判断ﾄﾚﾗﾝｽ
Private Const EPS = 0.0001          'ｲｺｰﾙ判断
'************

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub
    
    '選択
    Dim View As DrawingView: Set View = KCL.SelectItem("ﾋﾞｭｰを選択してください", "DrawingView")
    If KCL.IsNothing(View) Then Exit Sub
    
    'ﾄﾞｷｭﾒﾝﾄ取得
    Dim Doc As DrawingDocument: Set Doc = KCL.GetParent_Of_T(View, "DrawingDocument")
    
    '線取得
    KCL.SW_Start: Debug.Print "** Obj Start 002 ** :" & vbNewLine & "POLY_TOL-" & POLY_TOL & " : OVER_TOL-" & OVER_TOL
    Dim CrvLst As Collection: Set CrvLst = GetCurveList_Obj(View)
    Debug.Print "CrvLst- " & CrvLst.Count & "個 : " & KCL.SW_GetTime & "s"
    If KCL.IsNothing(CrvLst) Then Exit Sub
    
    '範囲取得
    Dim RngLst As Collection: Set RngLst = GetRangeBoxList(CrvLst)
    Debug.Print "RngLst- " & RngLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '長さ取得
    Dim LngLst As Collection: Set LngLst = GetLength_Prm(CrvLst)
    Debug.Print "LngLst- " & LngLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '折れ線化
    Dim PolyLst As Collection: Set PolyLst = GetPolyList(CrvLst)
    Debug.Print "PolyLst- " & PolyLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '4分木
    Dim QuadLst As Collection: Set QuadLst = Kcl_Quadtree.GetLinerQuadtreeList(RngLst, OVER_TOL)
    Debug.Print "QuadLst- " & QuadLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '重複線Idx取得
    Dim OverLst As Collection: Set OverLst = GetOverlapList(QuadLst, PolyLst, LngLst)
    Debug.Print "OverLst- " & OverLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '選択
    Call SelectOverCrv(OverLst, CrvLst, Doc.Selection)
    Debug.Print "SelectOverCrv - " & Doc.Selection.Count2 & "個 : " & KCL.SW_GetTime & "s"
End Sub


'*** catia ***
'ｺﾚｸｼｮﾝ要素の選択
Private Sub SelectOverCrv(ByVal OverList As Collection, ByVal CrvList As Collection, ByVal Sel As Selection)
    Dim Idx
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        For Each Idx In OverList
            .Add CrvList(Idx)
        Next
    End With
    CATIA.HSOSynchronized = True
End Sub

'線取得
Private Function GetCurveList_Obj(ByVal Vew As DrawingView) As Collection
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geos As GeometricElements: Set Geos = Vew.GeometricElements
    Dim Geo As GeometricElement
    For Each Geo In Geos
        Select Case Geo.GeometricType
            Case catGeoTypeUnknown, catGeoTypeAxis2D, catGeoTypeControlPoint2D, catGeoTypePoint2D
                '処理無し
            Case Else
                Lst.Add Geo
        End Select
    Next
    Set GetCurveList_Obj = Lst
End Function

'長さﾘｽﾄ取得
Private Function GetLength_Prm(ByVal Geos As Collection) As Collection
    Set GetLength_Prm = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    Dim Prm(1)
    For Each Geo In Geos
        With Geo
            Call .GetParamExtents(Prm)
            Lst.Add .GetLengthAtParam(Prm(0), Prm(1))
        End With
    Next
    Set GetLength_Prm = Lst
End Function

'領域ﾘｽﾄ取得
Private Function GetRangeBoxList(ByVal Geos As Collection) As Collection
    Set GetRangeBoxList = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    Dim Range(3)
    For Each Geo In Geos
        Call Geo.GetRangeBox(Range)
        Lst.Add Array(Array(Range(0), Range(1)), Array(Range(2), Range(3)))
    Next
    Set GetRangeBoxList = Lst
End Function

'折れ線化ﾘｽﾄ取得
Private Function GetPolyList(ByVal Geos As Collection) As Collection
    Set GetPolyList = Nothing
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim Geo As GeometricElement
    For Each Geo In Geos
        Select Case Geo.GeometricType
            Case catGeoTypeLine2D '"Line2D"
                Lst.Add Line2Poly(Geo)
            Case catGeoTypeCircle2D '"Circle2D"
                Lst.Add Circle2Poly(Geo)
            Case Else '"Spline2D", "Curve2D"
                Lst.Add Curve2Poly(Geo)
        End Select
    Next
    Set GetPolyList = Lst
End Function

'PolyAに対しPolyBが重複しているか?
Private Function IsOverlap(PolyA As Collection, PolyB As Collection) As Boolean
    IsOverlap = False

    Dim MinLng#, TempLng#, i&, j&
    For i = 1 To PolyB.Count
        MinLng = OVER_TOL + 1#
        For j = 1 To PolyA.Count - 1
            TempLng = Dist_AB_C(PolyA(j), PolyA(j + 1), PolyB(i))
            If MinLng > TempLng Then MinLng = TempLng
        Next
        If MinLng > OVER_TOL Then
            Exit Function
        End If
    Next
    IsOverlap = True
End Function

'重複線ﾘｽﾄ取得
Private Function GetOverlapList(ByVal QuadList As Collection, _
                                ByVal PolyList As Collection, _
                                ByVal LngList As Collection) As Collection
    Set GetOverlapList = Nothing

    Dim i&, j&, Spe As Collection
    Dim OvList As Collection: Set OvList = New Collection
    
    Dim EnumLst_T As Collection
    Dim EnumLst_U As Collection
    Dim OvAry '重複Fg 0-しない 1-参照のみ 2-重複
    OvAry = InitValueAry(PolyList.Count, 0)
    
    For Each Spe In QuadList
        '空間-空間
        Set EnumLst_T = Spe.Item(1)
        Call Q_ISort_List(EnumLst_T, LngList)
        For i = 1 To EnumLst_T.Count '重複線を判断する側(長いほうの線)
            For j = i + 1 To EnumLst_T.Count '重複線を判断される側
                If OvAry(EnumLst_T(j)) > 0 Then Exit For
                If IsOverlap(PolyList(EnumLst_T(i)), PolyList(EnumLst_T(j))) Then
                    OvList.Add EnumLst_T(j)
                    OvAry(EnumLst_T(j)) = 2
                End If
            Next
        Next
        
        '上位-空間
        Set EnumLst_U = Spe.Item(2)
        Call Q_ISort_List(EnumLst_U, LngList)
        For i = 1 To EnumLst_U.Count '重複線を判断する側
            For j = 1 To EnumLst_T.Count '重複線を判断される側
                If OvAry(EnumLst_T(j)) > 0 Then Exit For
                If LngList(EnumLst_U(i)) > LngList(EnumLst_T(j)) Then
                    If IsOverlap(PolyList(EnumLst_U(i)), PolyList(EnumLst_T(j))) Then
                        OvList.Add EnumLst_T(j)
                        OvAry(EnumLst_T(j)) = 2
                    End If
                End If
            Next
        Next
    Next
    Set GetOverlapList = OvList
End Function

'*** PolyLine ***
'線分折れ線化
Private Function Line2Poly(ByVal Geo As AnyObject) As Collection
    Set Line2Poly = Nothing
    
    Dim Prm(1) '始点終点ﾊﾟﾗﾒｰﾀ
    Dim Pos(3) '座標
    Dim StPos '始点座標
    Dim EnPos '終点座標
    
    'ｽﾌﾟﾗｲﾝ情報
    Call Geo.GetEndPoints(Pos)
    StPos = Array(Pos(0), Pos(1))
    EnPos = Array(Pos(2), Pos(3))
    
    'ｺﾋﾟﾍﾟされた座標軸対策
    'If Lng >= 2000000 Then Exit Function
    
    '折れ線化
    Dim List As Collection: Set List = New Collection
    Call List.Add(StPos)
    Call List.Add(EnPos)
    
    Set Line2Poly = List
End Function

'円弧折れ線化
Private Function Circle2Poly(ByVal Geo As AnyObject) As Collection
    Set Circle2Poly = Nothing
    
    '円弧情報
    Dim Prm(1) '始点終点ﾊﾟﾗﾒｰﾀ
    Dim StPos(1) '始点座標
    Dim EnPos(1) '終点座標
    Dim CnPos(1) '中心座標
    Dim R# '半径
    
    With Geo
        Call .GetParamExtents(Prm)
        Call .GetPointAtParam(Prm(0), StPos)
        Call .GetPointAtParam(Prm(1), EnPos)
        Call .GetCenter(CnPos)
        R = .Radius
    End With
    
    'ﾄﾚﾗﾝｽ内の増分ﾊﾟﾗﾒｰﾀ算出
    Dim IncPara# 'ﾊﾟﾗﾒｰﾀ増分
    Dim E_SPara# '終点-始点ﾊﾟﾗﾒｰﾀ
    Dim LoopCount& 'ｶｳﾝﾀ
    If R * 0.5 < POLY_TOL Then
        '小さな円弧への対応
        IncPara = (Prm(1) - Prm(0)) * 0.5
    Else
        '通常の円弧
        IncPara = ArcCos(1 - POLY_TOL / R) * 2
        E_SPara = Prm(1) - Prm(0)
        LoopCount = Fix(E_SPara / IncPara) + 1
        IncPara = E_SPara / LoopCount
    End If
    
    '増分の三角関数
    Dim SinTheta#, CosTheta#
    SinTheta = Sin(IncPara)
    CosTheta = Cos(IncPara)
    
    '折れ線化
    Dim AD#, BD# '回転前の点と中心点の距離
    Dim List As Collection: Set List = New Collection
    Dim i&
    Call List.Add(Array(StPos(0), StPos(1)))
    For i = 2 To LoopCount
        AD = List(i - 1)(0) - CnPos(0)
        BD = List(i - 1)(1) - CnPos(1)
        Call List.Add(Array(AD * CosTheta - BD * SinTheta + CnPos(0), _
                            AD * SinTheta + BD * CosTheta + CnPos(1)))
    Next
    Call List.Add(Array(EnPos(0), EnPos(1)))
    Set Circle2Poly = List
End Function

'ｽﾌﾟﾗｲﾝ折れ線化
Private Function Curve2Poly(ByVal Geo As AnyObject) As Collection
    Set Curve2Poly = Nothing
    
    Const CutCount = 4 '分割数
    
    'ｽﾌﾟﾗｲﾝ情報
    Dim Prm(1) '始点終点ﾊﾟﾗﾒｰﾀ
    Dim Pos(1) '座標
    
    With Geo
        Call .GetParamExtents(Prm)
        Call .GetPointAtParam(Prm(0), Pos)
    End With
    
    'ループ準備
    Dim PntList As Collection '折れ線化ﾘｽﾄ
    Set PntList = New Collection: Call PntList.Add(Pos)
    Dim CrvSPara#: CrvSPara = Prm(0) 'ｶｰﾌﾞ始点ﾊﾟﾗﾒｰﾀ
    Dim CrvEPara#: CrvEPara = Prm(1) 'ｶｰﾌﾞ終点ﾊﾟﾗﾒｰﾀ
    Dim LoopSPara#: LoopSPara = CrvSPara 'ﾙｰﾌﾟ始点ﾊﾟﾗﾒｰﾀ
    Dim LoopEPara#: LoopEPara = CrvEPara 'ﾙｰﾌﾟ終点ﾊﾟﾗﾒｰﾀ
    
    '非再帰折れ線近似化
    Dim SumPara# '増分ﾊﾟﾗﾒｰﾀ
    Dim LoopSPos(1) 'ﾙｰﾌﾟ始点
    Dim LoopEPos(1) 'ﾙｰﾌﾟ終点
    Dim Unit_Vec 'ﾙｰﾌﾟ始点からﾙｰﾌﾟ終点の単位ﾍﾞｸﾄﾙ
    Dim i&
    Dim CutPara#(CutCount) '分割ﾊﾟﾗﾒｰﾀ
    Dim CutPos(CutCount) '分割座標
    Dim CutMax: CutMax = Array(-1#, -1&) '分割点の最大距離とID
    Dim TempLng#  '一時距離
    Do
        'ループ初期設定
        SumPara = (LoopEPara - LoopSPara) / (CutCount + 2)
        Call Geo.GetPointAtParam(LoopSPara, LoopSPos)
        Call Geo.GetPointAtParam(LoopEPara, LoopEPos)
        Unit_Vec = Normaliz2d(LoopSPos, LoopEPos)
        
        
        '閉じた曲線-強制的に1点を登録
        If IsEmpty(Unit_Vec) Then
            CutPara(0) = Geo.GetParamAtLength(LoopSPara, POLY_TOL)
            Call Geo.GetPointAtParam(CutPara(0), Pos)
            Call PntList.Add(Pos)
            LoopSPara = CutPara(0)
            LoopEPara = CrvEPara
            GoTo Continue_Close
        End If
        
        '分割点作成　距離チェック
        For i = 0 To CutCount
            CutPara(i) = LoopSPara + SumPara * (i + 1)
            Call Geo.GetPointAtParam(CutPara(i), Pos)
            CutPos(i) = Pos
            TempLng = Lng_V_P(Unit_Vec, Sub2d(CutPos(i), LoopSPos))
            If CutMax(0) < TempLng Then '最大分割点更新
                CutMax(1) = i: CutMax(0) = TempLng
            End If
        Next
        
        '最大距離から節確定 LoopEParaが終点ならﾙｰﾌﾟ終了
        If CutMax(0) < POLY_TOL Then
            If LoopEPara >= CrvEPara Then
                Call Geo.GetPointAtParam(CrvEPara, Pos)
                Call PntList.Add(Pos)
                Exit Do 'ﾙｰﾌﾟ抜ける
            Else
                Call PntList.Add(LoopEPos)
                LoopSPara = LoopEPara
                LoopEPara = CrvEPara
            End If
        Else
            LoopEPara = CutPara(CutMax(1)) '再度処理
        End If
Continue_Close:
        CutMax(0) = -1# '距離初期化
        
        If EQ(LoopSPara, LoopEPara) Then
            '始点と終点がほぼ同一 未対応
            Stop
        End If
    Loop
    Set Curve2Poly = PntList
End Function


'*** Math ***
'ArcCos
Private Function ArcCos(ByVal V As Double) As Double
    ArcCos = Atn(-V / Sqr(-V * V + 1)) + 2 * Atn(1)
End Function

'2点距離の平方数
Private Function LengSqr(ByVal P1 As Variant, ByVal P2 As Variant) As Double
    Dim A#: A = P2(0) - P1(0)
    Dim B#: B = P2(1) - P1(1)
    LengSqr = A * A + B * B
End Function

'ｲｺｰﾙ
Private Function EQ(ByVal A As Double, ByVal B As Double) As Boolean
    EQ = IIf(Abs((A) - (B)) < EPS, True, False)
End Function


'*** Vecter ***
'参考サイト：http://www.deqnotes.net/acmicpc/2d_geometry/lines#intersection_of_lines
'参考サイト：http://marupeke296.com/COL_main.html
'点A,Bを端点とする線分と点Cとの距離
Private Function Dist_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    If Dot2d(Sub2d(B, A), Sub2d(C, A)) < EPS Then
        Dist_AB_C = Abs(Sqr(LengSqr(C, A)))
        Exit Function
    End If
    If Dot2d(Sub2d(A, B), Sub2d(C, B)) < EPS Then
        Dist_AB_C = Abs(Sqr(LengSqr(C, B)))
        Exit Function
    End If
    Dist_AB_C = Lng_AB_C(A, B, C)
End Function

'ﾍﾞｸﾄﾙABと点Cの距離
Private Function Lng_AB_C(ByVal A As Variant, ByVal B As Variant, ByVal C As Variant) As Double
    Lng_AB_C = Abs(Cross2d(Sub2d(B, A), Sub2d(C, A))) / Abs(Sqr(LengSqr(B, A)))
End Function

'単位ﾍﾞｸﾄﾙVと点Pの距離
Private Function Lng_V_P(ByVal V As Variant, ByVal P As Variant) As Double
    Lng_V_P = Abs(Cross2d(V, P))
End Function

'単位ﾍﾞｸﾄﾙ
Private Function Normaliz2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Dim vec: vec = Sub2d(V2, V1)
    Dim tmp: tmp = Sqr(Dot2d(vec, vec))
    If EQ(tmp, 0#) Then
        Normaliz2d = Empty
        Exit Function
    End If
    Normaliz2d = Array(vec(0) / tmp, vec(1) / tmp)
End Function

'差2D
Private Function Sub2d(ByVal V1 As Variant, ByVal V2 As Variant) As Variant
    Sub2d = Array(V1(0) - V2(0), V1(1) - V2(1))
End Function

'内積2D
Private Function Dot2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
    Dot2d = V1(0) * V2(0) + V1(1) * V2(1)
End Function

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


'*** etc ***
'初期化済みｺﾚｸｼｮﾝ生成
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 Function InitValueAry(ByVal Count&, ByVal Value&) As Variant
    Dim Ary(): ReDim Ary(Count + 1)
    Dim i&
    For i = 1 To Count
        Ary(i) = Value
    Next
    InitValueAry = Ary
End Function

'長さ順の列挙用Idxを取得するQIｿｰﾄ
Private Sub Q_ISort_List(ByRef IdxList As Collection, ByVal LngList As Collection)
    Dim THREASHOLD&: THREASHOLD = 16 '64
    Dim Stack As Collection: Set Stack = New Collection
    Stack.Add 1, CStr(Stack.Count + 1)
    Stack.Add IdxList.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
            Pivot = LngList(IdxList((LeftIdx + RightIdx) / 2))
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While LngList(IdxList(i)) > Pivot
                    i = i + 1
                Loop
                Do While LngList(IdxList(j)) < Pivot
                    j = j - 1
                Loop
                If i <= j Then
                    Temp1 = IdxList(i)
                    Temp2 = IdxList(j)
                    IdxList.Add Temp1, After:=j
                    IdxList.Remove j
                    IdxList.Add Temp2, After:=i
                    IdxList.Remove i
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 0 Then
                If RightIdx - i <= THREASHOLD Then
                    ComboInsertionSort IdxList, i, RightIdx, LngList
                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 IdxList, LeftIdx, j, LngList
                Else
                    Stack.Add LeftIdx, CStr(Stack.Count + 1)
                    Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
    Loop
End Sub

'長さ順の列挙用Idxを取得するQIｿｰﾄ用
Private Sub ComboInsertionSort(ByRef IdxList, ByVal MinIdx&, ByVal MaxIdx&, ByVal LngList As Collection)
    Dim Temp1, Temp2
    Dim i&, j&: j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
        
            If LngList(IdxList(i + 1)) > LngList(IdxList(i)) Then
                Temp1 = IdxList(i + 1)
                Temp2 = IdxList(i)
                IdxList.Add Temp2, After:=i + 1
                IdxList.Remove i + 1
                IdxList.Add Temp1, After:=i
                IdxList.Remove i
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

重複線をﾁｪｯｸしている "GetOverlapList" のｸｽﾞっぷりが半端じゃないの
ですが･･･。(一時的に配列に入れて、長さの短いものだけを抜き出すとか
すれば良いかも)

前回のものと比較する為、各2回実行してみました。

Ver0.0.1

** Obj Start 001 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 2.021s
RngLst- 3955個 : 2.6s
LngLst- 3955個 : 4.21s
PolyLst- 3955個 : 15.424s
EnumLst- 3955個 : 17.562s
OverLst- 21779個 : 746.115s
SelectOverCrv - 2876個 : 748.404s

** Obj Start 001 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 3.537s
RngLst- 3955個 : 4.155s
LngLst- 3955個 : 5.442s
PolyLst- 3955個 : 18.873s
EnumLst- 3955個 : 21.02s
OverLst- 21779個 : 752.552s
SelectOverCrv - 2876個 : 755.09s

---------------------
Ver0.0.2
(分割最大ﾚﾍﾞﾙ Lv5)

** Obj Start 002 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 2.533s
RngLst- 3955個 : 3.148s
LngLst- 3955個 : 4.44s
PolyLst- 3955個 : 16.873s
QuadLst- 290個 : 40.142s
OverLst- 2487個 : 75.37s
SelectOverCrv - 2487個 : 76.099s

** Obj Start 002 ** :
POLY_TOL-0.1 : OVER_TOL-0.1
CrvLst- 3955個 : 3.575s
RngLst- 3955個 : 4.204s
LngLst- 3955個 : 5.51s
PolyLst- 3955個 : 19.187s
QuadLst- 290個 : 43.989s
OverLst- 2487個 : 79.469s
SelectOverCrv - 2487個 : 80.05s

処理速度は1割ぐらいまで短縮できたのですが、
SelectOverCrvの行の個数が重複線と判断したものです。
総当りに比べて、400個ぐらい見落としている・・・。
何処が悪いんだろう?

又、QuadLstの行の290個は、分割した空間内に要素が存在していた
空間数なのですが、最大ﾚﾍﾞﾙ5の場合の空間数は1365個です。
(殆どが利用されていない)
良く考えなかったので(と言うかわかっていなかった為)ｵﾘｼﾞﾅﾙの
ように大量の配列を用意していたのですが、空間番号をｷｰとした
ﾊｯｼｭﾃｰﾌﾞﾙを利用すれば、無駄に大きな配列を用意する必要が無い事に、
今朝の通勤中に気が付きました。　ん～直すかな･･･。

流用して、4分木る 3

こちらの続きです。
流用して、4分木る 2 - C#ATIA

やっと、2度と見たくない程の汚いｺｰﾄﾞになってしまいましたが
組み合わせの効率化を促す、線形4分木が出来ました。

"KCL_Quadtree.bas" と言う名称の標準ﾓｼﾞｭｰﾙとします。
'KCL' と、先日のDotNET Framework ArrayList ﾗｯﾊﾟｰｸﾗｽ 'cList'
が必要です。
ArrayListﾗｯﾊﾟｰｸﾗｽをお借りしてみる2 - C#ATIA

'vba KCL_Quadtree Ver0.0.1
'KCL_Quadtree.bas - 標準ﾓｼﾞｭｰﾙ
'using-'KCL0.09' -'cList0.0.1'
'ﾓｰﾄﾝ順序を利用した4分木空間分割

Option Explicit

Private Const MAXLEVEL = 5&                     '有効空間分割最大ﾚﾍﾞﾙ
Private Const MAXCOUNT = 200&                   '同一空間内最大数(目安)
Private Const DUB_MAX = 1.79769313486231E+308   'Double Max
Private Const DUB_MIN = -1.79769313486231E+308  'Double Min
Private Const LNG_MAX = 2147483647              'Long Max
Private Const DBFG = False                      'ﾃﾞﾊﾞｯｸﾞ True/False
    
Private m_Level&                                '分割ﾚﾍﾞﾙ
Private m_Tolerance#                            'ﾄﾚﾗﾝｽ
Private m_AxisCount&                            '空間分割時の各軸の最大数
Private m_MinPos                                '空間最小座標
Private m_Unit                                  '空間単位ｻｲｽﾞ
Private m_CellCount&()                          'ﾚﾍﾞﾙ毎の空間数
Private m_CellAllCount&()                       '指定ﾚﾍﾞﾙまでの合計空間数
Private m_Tolerance_Offset                      'ﾄﾚﾗﾝｽｵﾌｾｯﾄ 左上右下用

'線形4分木ﾘｽﾄ取得
''' @param :Rngboxs-Collection(array(array(Double),array(Double))-座標値郡
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @return:Collection((Collection(long)-その空間Idx
'''                    (Collection(long))-上位空間Idx
Function GetLinerQuadtreeList(ByVal Rngboxs As Collection, ByVal Tolerance#) As Collection
    Set GetLinerQuadtreeList = Nothing
    
    'cList化
    Dim Vols As cList: Set Vols = InitList()
    Set Vols = Rngbox2Volume(Rngboxs)

    '座標値郡のIdxList作成
    Dim IdxList As cList: Set IdxList = InitRangeList(Vols.Count)
    
    '空間内最大数以下の場合、そのまま返す
    Dim DecidedList As cList: Set DecidedList = InitList()
    If Vols.Count < MAXCOUNT Then
        Call DecidedList.Add(InitSpace(IdxList.ToArray()))
        GoTo FuncEnd
    End If
    
    '初期設定
    If Not SetStart(Tolerance, MAXCOUNT) Then
        MsgBox "設定値が不正です"
        Exit Function
    End If
    
    '空間情報
    If Not SetSpaceInfo(Vols, IdxList) Then '空間が小さすぎる
        Call DecidedList.Add(InitSpace(IdxList.ToArray()))
        GoTo FuncEnd
    End If
    
    '空間ﾎﾟｲﾝﾀ配列
    Dim SpaceAryCount&: SpaceAryCount = m_CellAllCount(m_Level) - 1
    Dim SpeceAry: SpeceAry = InitRangeAry(SpaceAryCount, -1&)
    
    '空間に配置
    Dim Space, i&, Idx, Morton&
    Dim SpaceEnum As cList, UprIdxList As cList
    For Each Idx In IdxList
        Morton = GetLinerNumber(Vols.Item(Idx))
        If SpeceAry(Morton) < 0 Then
            Call DecidedList.Add(InitSpace())
            SpeceAry(Morton) = DecidedList.Count - 1
        End If
        Call DecidedList.Item(SpeceAry(Morton)).Item(0).Add(Idx)
    Next
    
    '有効空間Idx取得
    Set SpaceEnum = GetValidSpaceEnum(SpeceAry)
    Call SpaceEnum.Sort
    
    '上位空間Idx取得-上位空間から行う
    For Each Idx In SpaceEnum
        Set UprIdxList = GetUprSpaceIdxList(Idx, SpeceAry)
        Call UprIdxList.Sort
        Set DecidedList.Item(SpeceAry(Idx)).Item(1) = _
                        GetUprAllList(UprIdxList, DecidedList)
    Next
    If DBFG Then Call DumpSpaceAllIdx(DecidedList)
    
    '上位空間順に再配置
    Dim SortList As cList: Set SortList = InitList()
    For Each Idx In SpaceEnum
        SortList.Add DecidedList.Item(SpeceAry(Idx))
    Next
    Call SortList.TrinToSize
    Set DecidedList = SortList
    If DBFG Then Call DumpSpaceAllIdx(DecidedList)
    
FuncEnd:
    Set GetLinerQuadtreeList = SpaceList2IdxCol(DecidedList)
End Function

'*** Quadtree ***
'有効な上位空間Idx取得
''' @param :LinerNum-long-線形4分木Idx
''' @param :SpaAry-Array-空間ﾎﾟｲﾝﾀ
''' @return:cList(long)-線形4分木Idx
Private Function GetUprSpaceIdxList(ByVal LinerNum As Long, _
                                    ByVal SpeAry As Variant) As cList
    Dim Lst As cList: Set Lst = InitList()
    Set GetUprSpaceIdxList = Lst
    
    '全上位空間Idx
    Dim N: N = LinerNum
    Do Until N < 1
        N = Fix((N - 1) * 0.25)
        Lst.Add CLng(N)
    Loop
    If Lst.Count < 1 Then Exit Function
    
    '有効空間Idx
    Dim Upr As cList: Set Upr = InitList()
    Dim Idx
    For Each Idx In Lst
        If SpeAry(Idx) >= 0 Then
            Upr.Add SpeAry(Idx)
        End If
    Next
    
    Set GetUprSpaceIdxList = Upr
End Function

'有効空間取得
''' @param :SpaAry-Array-空間ﾎﾟｲﾝﾀ
''' @return:cList(long)
Private Function GetValidSpaceEnum(ByVal SpaAry As Variant) As cList
    Dim List As cList: Set List = InitList()
    Dim i&
    For i = 0 To UBound(SpaAry)
        If SpaAry(i) >= 0 Then List.Add i
    Next
    Set GetValidSpaceEnum = List
End Function

'有効空間全VolIdx取得
''' @param :IdxList-cList
''' @param :SpaList-cList
''' @return:cList(long)
Private Function GetUprAllList(ByVal IdxList As cList, ByVal SpaList As cList) As cList
    Dim UprLst As cList: Set UprLst = InitList()
    Set GetUprAllList = UprLst
    If IdxList.Count < 1 Then Exit Function
    
    Dim List As cList: Set List = InitList()
    Dim Idx, Upr
    For Each Idx In IdxList
        Set List = FlattenSpace(SpaList.Item(Idx))
        If KCL.IsNothing(List) Then GoTo Continue
        For Each Upr In List
            If Not UprLst.Contains(Upr) Then
                UprLst.Add Upr
            End If
        Next
Continue:
    Next
    
    Set GetUprAllList = UprLst
End Function

'空間作成
''' @param :This-Variant
''' @param :Upr-Variant
''' @return:cList(cList,cList)
Private Function InitSpace(Optional ByVal This, Optional ByVal Upr) As cList
    Set InitSpace = InitList()
    InitSpace.Add InitList(This)
    InitSpace.Add InitList(Upr)
End Function

'空間平坦化
''' @param :Space-cList(cList,cList)
''' @return:cList
Private Function FlattenSpace(ByVal Space As cList) As cList
    Set FlattenSpace = Nothing
    If Space.Count < 1 Then Exit Function
    Set FlattenSpace = List_join(Space.ItemObj(0), _
                       List_diff(Space.ItemObj(0), Space.ItemObj(1)))
End Function

'線形4分木準備
''' @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
    
    ReDim m_CellCount(MAXLEVEL): m_CellCount(0) = 1
    ReDim m_CellAllCount(MAXLEVEL): m_CellAllCount(0) = 1
    Dim i&
    For i = 1 To UBound(m_CellCount)
        m_CellCount(i) = m_CellCount(i - 1) * 4
        m_CellAllCount(i) = m_CellAllCount(i - 1) + m_CellCount(i)
    Next
    
    m_Tolerance_Offset = Array(Tolerance * -1#, Tolerance)
    SetStart = True
End Function

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

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

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

'線形4分木RangeBoxに変換 左上と右下
''' @param :Vol-cList(array(Double),array(Double))-ﾎﾞﾘｭｰﾑ座標値
''' @return:cList(array(Double),array(Double))
Private Function GetMortonRngBox(ByVal Vol As cList) As cList
    If Vol(0)(0) > Vol(1)(0) Then Call SwapNum(Vol(0)(0), Vol(1)(0))
    If Vol(0)(1) < Vol(1)(1) Then Call SwapNum(Vol(0)(1), Vol(1)(1))
    
    Dim Mrb As cList: Set Mrb = InitList()
    Mrb.Add Vol(0)
    Mrb.Add Vol(1)
    Set GetMortonRngBox = Mrb
End Function

'ﾎﾞﾘｭｰﾑから線形4分木ｲﾝﾃﾞｯｸｽNoを取得
''' @param :Vol-cList(array(Double),array(Double))-ﾎﾞﾘｭｰﾑ座標値
''' @return:Long
Private Function GetLinerNumber(ByVal Vol As cList) As Long
    '点のﾓｰﾄﾝNoを算出
    Dim SwVol: Set SwVol = GetMortonRngBox(Vol)
    Dim Lt&: Lt = GetPointElem(AryAddAry(SwVol(0), m_Tolerance_Offset))
    Dim Rb&: Rb = GetPointElem(AryAddAry(SwVol(1), AryMul(m_Tolerance_Offset, -1)))
    
    'Xorで所属レベル取得
    Dim Def&: Def = Rb Xor Lt
    Dim HiLevel&
    If Def = 0 Then
        HiLevel = 0 '最小ﾚﾍﾞﾙで同一空間番号
    Else
        HiLevel = 1
        Dim i&, Check&
        For i = 0 To m_Level
            Check = (sr(Def, (i * 2))) And &H3
            If Not Check = 0 Then HiLevel = i + 1
        Next
    End If
    
    'ﾎﾞﾘｭｰﾑの空間番号とﾚﾍﾞﾙから線形4分木ｲﾝﾃﾞｯｸｽNoを算出
    Dim SpaceNum&: SpaceNum = sr(Rb, (HiLevel * 2))
    Dim AddNum&: AddNum = (m_CellCount(m_Level - HiLevel) - 1) / 3
    SpaceNum = SpaceNum + AddNum
    
    '不正ﾃﾞｰﾀﾁｪｯｸ
    If SpaceNum > m_CellAllCount(m_Level) - 1 Then
        GetLinerNumber = LNG_MAX
    End If
    GetLinerNumber = SpaceNum
End Function

'ﾋﾞｯﾄ分割関数2D
''' @param :n-long
''' @return:long
Private Function BitSeparateFor2D(ByVal N&) As Long
    Dim S&: S = N
    S = (S Or sl(S, 8)) And &HFF00FF
    S = (S Or sl(S, 4)) And &HF0F0F0F
    S = (S Or sl(S, 2)) And &H33333333
    BitSeparateFor2D = (S Or sl(S, 1)) And &H55555555
End Function

'4分木ﾓｰﾄﾝ順序算出関数
''' @param :x-long
''' @param :y-long
''' @return:long
Private Function Get2DMortonNumber(ByVal x&, ByVal y&) As Long
   Get2DMortonNumber = BitSeparateFor2D(x) Or _
                       sl(BitSeparateFor2D(y), 1)
End Function

'線形4分木ｲﾝﾃﾞｯｸｽ取得関数
''' @param :Pos-array(Double)
''' @return:long
Private Function GetPointElem(ByVal Pos As Variant) As Long
   GetPointElem = Get2DMortonNumber(Fix((Pos(0) - m_MinPos(0)) / m_Unit(0)), _
                                    Fix((Pos(1) - m_MinPos(1)) / m_Unit(1)))
End Function

'*** Math ***
'配列と配列の足し算
Private Function AryAddAry(ByVal A, ByVal B) As Variant
    AryAddAry = Array(A(0) + B(0), A(1) + B(1))
End Function

'配列同士の引き算
Private Function ArySubAry(ByVal A, ByVal B) As Variant
    ArySubAry = Array(A(0) - B(0), A(1) - B(1))
End Function

'配列と実数の足し算
Private Function AryAdd(ByVal A, ByVal B#) As Variant
    AryAdd = Array(A(0) + B, A(1) + B)
End Function

'配列と実数の掛け算
Private Function AryMul(ByVal A, ByVal B#) As Variant
    AryMul = Array(A(0) * B, A(1) * B)
End Function

'配列と実数の割り算
Private Function AryDiv(ByVal A, ByVal B#) As Variant
    AryDiv = Array(A(0) / B, A(1) / B)
End Function

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

' 左シフト
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

' 右シフト(算術(>>)ではなく論理(>>>)シフトに相当)
Private Function sr(ByVal x&, ByVal N&) As Long
    If N = 0 Then
        sr = x
    Else
        Dim y: y = x And &H7FFFFFFF
        Dim z
        If N = 32 - 1 Then
            z = 0
        Else
            z = y \ CLng(2 ^ N) 'ひょっとしたらCLng要らないかも
        End If
        If y <> x Then z = z Or CLng(2 ^ (32 - N - 1))
        sr = z
    End If
End Function


'*** List/Array/Collection ***
'ﾘｽﾄの作成
Private Function InitList(Optional ByVal Data) As cList
    Dim List As cList: Set List = New cList
    Set InitList = List
    If IsMissing(Data) Then Exit Function
    
    Select Case True
        Case IsArray(Data)
            Dim i&
            For i = 0 To UBound(Data)
                List.Add Data(i)
            Next
        Case TypeName(Data) = "Collection"
            Dim V
            For Each V In Data
                List.Add V
            Next
        Case Else
            List.Add V
    End Select
End Function

'初期化済みﾘｽﾄ生成
Private Function InitRangeList(ByVal Count&) As cList
    Dim List As cList: Set List = InitList()
    Dim i&
    For i = 0 To Count - 1
        List.Add i
    Next
    Set InitRangeList = List
End Function

'Lst1に対しLst2の重複を削除したcListを返す
Private Function List_diff(ByVal Lst1 As cList, ByVal Lst2 As cList) As cList
    Set List_diff = Nothing
    If Lst2.Count < 1 Then Exit Function
    If Lst1.Count < 1 Then
        Set List_diff = Lst2
        Exit Function
    End If
    
    Dim Lst As cList: Set Lst = InitList()
    Dim V
    For Each V In Lst2
        If Not Lst.Contains(V) Then Lst.Add V
    Next
    Set List_diff = Lst
End Function

'cList連結
Private Function List_join(ByVal Lst1 As cList, ByVal Lst2 As cList) As cList
    Set List_join = Nothing
    If KCL.IsNothing(Lst1) And KCL.IsNothing(Lst2) Then Exit Function
    If KCL.IsNothing(Lst1) Then Set List_join = Lst2: Exit Function
    If KCL.IsNothing(Lst2) Then Set List_join = Lst1: Exit Function
        
    Dim Diff As cList: Set Diff = List_diff(Lst1, Lst2)
    Dim Lst As cList: Set Lst = List_DeepCopy(Lst1)
    Dim V
    For Each V In Diff
        Lst.Add V
    Next
    Set List_join = Lst
End Function

'cListｸﾛｰﾝ
Private Function List_DeepCopy(ByVal Lst As cList) As cList
    Set List_DeepCopy = Nothing
    If KCL.IsNothing(Lst) Then Exit Function
        
    Dim DC As cList: Set DC = InitList()
    DC.capacity = Lst.Count + 1
    Dim V
    For Each V In Lst
        DC.Add V
    Next
    Set List_DeepCopy = DC
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

'ｺﾚｸｼｮﾝの作成
'OffsetはcListとｺﾚｸｼｮﾝのｲﾝﾃﾞｯｸｽ違いを吸収する苦肉の策
Private Function InitCol(Optional ByVal Data, Optional ByVal Offset) As Collection
    Dim Col As Collection: Set Col = New Collection
    Set InitCol = Col
    If IsMissing(Data) Then Exit Function
    
    Select Case True
        Case IsArray(Data)
            Dim i&
            For i = 0 To UBound(Data)
                Col.Add Data(i)
            Next
        Case TypeName(Data) = "cList"
            Dim V
            If IsMissing(Offset) Then
                For Each V In Data
                    Col.Add V
                Next
            Else
                For Each V In Data
                    Col.Add V + Offset
                Next
            End If
        Case Else
            Col.Add V
    End Select
End Function


'*** etc ***
'Swap 値型
Private Sub SwapNum(ByRef A, ByRef B)
    Dim tmp: tmp = A: A = B: B = tmp
End Sub

'座標郡の型変換
''' @param :Col-Collection(Collection(array(Double),array(Double))
''' @return:cList(cList(array(Double),array(Double))
Private Function Rngbox2Volume(ByVal Rngboxs As Collection) As cList
    Dim Lst As cList: Set Lst = InitList()
    Dim Rb
    For Each Rb In Rngboxs
        Lst.Add InitList(Rb)
    Next
    Set Rngbox2Volume = Lst
End Function

'Idx郡の型変換
''' @param :Col-Collection(Collection(array(Double),array(Double))
''' @return:cList(cList(array(Double),array(Double))
Private Function SpaceList2IdxCol(ByVal SpaceList As cList) As Collection
    Dim Col As Collection: Set Col = New Collection
    Dim Spa As cList, UprLow As Collection, Lv
    For Each Spa In SpaceList
        Set UprLow = InitCol()
        UprLow.Add InitCol(Spa.Item(0), 1)
        UprLow.Add InitCol(Spa.Item(1), 1)
        Col.Add UprLow
    Next
    Set SpaceList2IdxCol = Col
End Function

'*** debug ***
'確認用
Private Sub DumpQuadIdx(ByVal PosList)
    Dim Pos
    Debug.Print " **** "
    For Each Pos In PosList
        Debug.Print "Pos:" & Pos(0) & "," & Pos(1), _
                    "MotonNo:" & GetPointElem(Pos)
    Next
End Sub

Private Sub DumpSpaceAllIdx(ByVal Spaces) ' As cList)
    Dim S, U, T, i&, Fs
    Debug.Print " **** "
    
    For Each S In Spaces
        If TypeName(S) = "cList" Then
            Fs = 0
        Else
            Fs = 1
        End If
    
        If S.Item(Fs).Count < 1 Then
            T = "無し"
        Else
            If TypeName(S) = "cList" Then
                T = Join(S.Item(Fs).ToArray(), ",")
            Else
                Set T = InitList(S.Item(Fs))
                T = Join(T.ToArray(), ",")
            End If
        End If
        
        If S.Item(Fs + 1).Count < 1 Then
            U = "無し"
        Else
            If TypeName(S) = "cList" Then
                U = Join(S.Item(Fs + 1).ToArray(), ",")
            Else
                Set U = InitList(S.Item(Fs + 1))
                U = Join(U.ToArray(), ",")
            End If
        End If
        
        Debug.Print "This: " & T
        Debug.Print "Upr : " & U
        Debug.Print
    Next
End Sub
'***********************
'ver0.0.1 - 完成

あまりに複雑すぎて、空間の再分割は諦めました。

GetLinerQuadtreeList関数に
第一引数 - 曲線のﾚﾝｼﾞﾎﾞｯｸｽ郡
第二引数 - ﾄﾚﾗﾝｽ
で投げると、ﾚﾝｼﾞﾎﾞｯｸｽと同一のｲﾝﾃﾞｯｸｽが、空間分割されたｺﾚｸｼｮﾝとして
戻ってきます。
戻り値は、 Collection(単位空間(空間内ｲﾝﾃﾞｯｸｽ郡,上位空間ｲﾝﾃﾞｯｸｽ郡))
の状態です。(他人にはわかり難い･･･自分でも忘れそう)

これにより、ｵﾘｼﾞﾅﾙで行っている衝突ﾘｽﾄの作成を避け、全空間を処理する
為の複雑なﾙｰﾌﾟ?処理を行わずに、単純に戻り値のｺﾚｸｼｮﾝを走査するだけで
終了できるようにしました。

重複線を処理する際の組み合わせは、
・空間内ｲﾝﾃﾞｯｸｽ同士の組み合わせで重複ﾁｪｯｸ
・空間内ｲﾝﾃﾞｯｸｽと上位空間ｲﾝﾃﾞｯｸｽの組み合わせで重複ﾁｪｯｸ
の2段階となりますが、恐らく大幅に組み合わせ数を減らす事が可能では
ないかな?　と思っています。

これを利用したﾏｸﾛは次回に。
出来れば、これを再度修正したりしたくないです･･･。

ArrayListﾗｯﾊﾟｰｸﾗｽをお借りしてみる2

こちらの続きです。
ArrayListﾗｯﾊﾟｰｸﾗｽをお借りしてみる - C#ATIA

ｲﾛｲﾛとｺﾒﾝﾄで教えて頂いたので、こちらの.NETFramework_ArrayListの
ﾗｯﾊﾟｰｸﾗｽに
AarrayListをvbaで使いやすいようにラップしてみた : 趣味のプログラムあれこれ

こちらを反映してみました。
Wrap .Net ArrayList with custom VBA class get iterator - Stack Overflow

ArrayListﾗｯﾊﾟｰｸﾗｽです。こちらは直接ﾍﾟｰｽﾄするとｴﾗｰになってしまいます。
一度ｴｸｽﾎﾟｰﾄして･･･thomさんのこちらのｻｲﾄがわかりやすいかと思います。

VBA 自作のCollectionクラスをFor Eachでまわす裏ワザ - t-hom’s diary

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'vba .NETFramework_ArrayList_Rapper_Class
'http://blog.livedoor.jp/midorityo/archives/50749809.html
'http://stackoverflow.com/questions/25580867/wrap-net-arraylist-with-custom-vba-class-get-iterator
Option Explicit

Private arraylist As Object

Private Sub Class_Initialize()
    Set arraylist = CreateObject("System.Collections.ArrayList")
End Sub

'修正
Private Sub Class_Terminated()
    If Not internalList Is Nothing Then
        On Error Resume Next
        arraylist.Dispose
        Err.Clear
    End If
End Sub

Function Add(ByVal value As Variant) As Long
    Add = arraylist.Add(value)
End Function

Function BinarySearch(ByVal value As Variant, _
                        Optional ByVal conparer As Long = 0, _
                        Optional ByVal Index As Long = -1, _
                        Optional ByVal count As Long = 0) As Long
    Dim rtn As Long
    
    If Index < 0 Then
        If conparer = 0 Then
            rtn = arraylist.BinarySearch_2(value)
        Else
            rtn = arraylist.BinarySearch_3(value, CreateObject("System.Collections.CaseInsensitiveComparer"))
        End If
    Else
        If count < 0 Then count = 0
        If conparer = 0 Then
            rtn = arraylist.BinarySearch(Index, count, value, Nothing)
        Else
            rtn = arraylist.BinarySearch(Index, count, value, CreateObject("System.Collections.CaseInsensitiveComparer"))
        End If
    End If
    BinarySearch = rtn
End Function

Sub Clear()
    arraylist.Clear
End Sub

Function Contains(ByVal Item As Variant) As Boolean
    Contains = arraylist.Contains(Item)
End Function

Function IndexOf(ByVal value As Variant, _
                    Optional startIndex As Long = -1, _
                    Optional count As Long = 0) As Long
    Dim rtn As Long
    
    If startIndex < 0 Then
        rtn = arraylist.IndexOf_3(value)
    Else
        If count < 1 Then
            rtn = arraylist.IndexOf(value, startIndex)
        Else
            rtn = arraylist.IndexOf_2(value, startIndex, count)
        End If
    End If
    IndexOf = rtn
End Function

Sub Insert(ByVal Index As Long, ByVal value As Variant)
    arraylist.Insert Index, value
End Sub

Function LastIndexOf(ByVal value As Variant, _
                Optional ByVal startIndex As Long = -1, _
                Optional ByVal count As Long = 0) As Long
    Dim rtn As Long
    If startIndex < 0 Then
        rtn = arraylist.LastIndexOf(value)
    Else
        If count < 1 Then
            rtn = arraylist.LastIndexOf(value, startIndex)
        Else
            rtn = arraylist.LastIndexOf(value, startIndex, count)
        End If
    End If
    LastIndexOf = rtn
End Function

Sub Remove(ByVal obj As Variant)
    arraylist.Remove (obj)
End Sub

Sub RemoveAt(ByVal Index As Long)
    arraylist.RemoveAt (Index)
End Sub

Sub Reverse(Optional ByVal Index As Long = -1, _
            Optional ByVal count As Long = 0)
    If Index < 0 Then
        arraylist.Reverse
    Else
        If count < 0 Then count = 0
        arraylist.Reverse_2 Index, count
    End If
End Sub

Sub Sort(Optional ByVal comparer As Long = 0, _
            Optional ByVal Index As Long = -1, _
            Optional ByVal count As Long = 0)
    If Index < 0 Then
        If comparer = 0 Then
            arraylist.Sort
        Else
            arraylist.Sort_2 (CreateObject("System.Collections.CaseInsensitiveComparer"))
        End If
    Else
        If comparer = 0 Then
            arraylist.Sort_3 Index, count, Nothing
        Else
            arraylist.Sort_3 Index, count, CreateObject("System.Collections.CaseInsensitiveComparer")
        End If
    End If
End Sub

Function ToArray() As Variant
    ToArray = arraylist.ToArray
End Function

Function ToString() As String
    ToString = arraylist.ToString
End Function

Sub TrinToSize()
    arraylist.TrimToSize
End Sub

Property Get Item(ByVal Index As Long) As Variant
    If IsObject(arraylist.Item(Index)) Then
        Set Item = arraylist.Item(Index)
    Else
        Item = arraylist.Item(Index)
    End If
End Property

Property Let Item(ByVal Index As Long, ByVal value As Variant)
    Let arraylist(Index) = value
End Property

Property Set Item(ByVal Index As Long, ByVal value As Variant)
    Set arraylist(Index) = value
End Property

Property Get capacity() As Long
    capacity = arraylist.capacity
End Property

Property Let capacity(ByVal value As Long)
    arraylist.capacity = value
End Property

Property Get count() As Long
    count = arraylist.count
End Property

'追記

Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
        Dim enumerator As IUnknown
        Set enumerator = arraylist.GetEnumerator(0, arraylist.count)
        Set NewEnum = enumerator
End Function

Property Get ItemVal(ByVal Index As Long) As Variant
Attribute Value.VB_UserMemId = 0
    Let ItemVal = arraylist.Item(Index)
End Property

Property Get ItemObj(ByVal Index As Long) As Variant
Attribute Value.VB_UserMemId = 0
    Set ItemObj = arraylist.Item(Index)
End Property

Property Let ItemVal(ByVal Index As Long, ByVal value As Variant)
    Let arraylist(Index) = value
End Property

Property Set ItemObj(ByVal Index As Long, ByVal value As Variant)
    Set arraylist(Index) = value
End Property

修正内容と結果としては
○ForEach出来ない　→　NewEnumと下記を追加
　→　ForEachできました

○Item Getのオブジェクト判定を抜いて　→
　・ﾌﾟﾛﾊﾟﾃｨの　Get ItemVal / Let ItemVal
　・ﾌﾟﾛﾊﾟﾃｨの　Get ItemObj / Set ItemObj
　を追加し、
　Get側に 'Attribute Value.VB_UserMemId = 0'
　を記載
　→　ForEachできました

○Integer型　→　Long型
　→　十分なｻｲｽﾞが確保できるようになりました。

○ﾃﾞｽﾄﾗｸﾀが単なるNothing　→　stackoverflowのDispose方式
　→　まぁ実感は特には･･･

ItemﾌﾟﾛﾊﾟﾃｨのGet,Set,Letを残しておかないと、For文がｴﾗｰに
なっちゃいました。　又、ｲﾝﾃﾞｸｻでの呼び出しも可能になっていました。
これなら、これ一本で十分そうです。

指定した2D要素を、指定した原点位置でｺﾋﾟﾍﾟする

DXF(2D)ﾃﾞｰﾀを受け取って3Dにﾓﾃﾞﾘﾝｸﾞする作業は、ほぼ無いのですが
大まかな形状を作成したい時が偶にあり、行います。

DXFをｲﾝﾎﾟｰﾄして手っ取り早く、3Dに貼り付けたいのですが困るのが
原点合わせです。　Draw側で原点をあわせて3Dにﾍﾞﾀｯと貼り付けるか?
3Dにﾍﾞﾀｯと貼り付けた後に、ｽｹｯﾁで原点をあわせるか?
どちらにしても、個人的にはCATIAの2Dの移動ｺﾏﾝﾄﾞが、異常な程
使いにくく感じてます。

この作業を補助するﾏｸﾛを過去に "Unofficial CATIA User Forum" で
Upしたのですが、あまりにｺｰﾄﾞが汚かったため再度直したものです。

指定した2D要素を指定した原点位置を元に、新たなﾋﾞｭｰにｺﾋﾟﾍﾟする
ﾏｸﾛです。

'vba sample_Draw_CloneGeo2D ver0.0.2  using-'KCL0.09'
'選択したDraw2D要素を新たなViewにｺﾋﾟﾍﾟします。
'2Dｺﾝﾎﾟｰﾈﾝﾄは選択出来ないので、事前に展開してください

Private Const DBL_MAX = 1.79769313486231E+308       'Double Max
Private Const EPS = 0.0001                          'ｲｺｰﾙ判断
Private Const OFFSET = 50                           '他ﾋﾞｭｰとの距離

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("DrawingDocument") Then Exit Sub

    '準備
    Dim Doc As DrawingDocument: Set Doc = CATIA.ActiveDocument
    Dim ActSheet As DrawingSheet: Set ActSheet = Doc.Sheets.ActiveSheet
    Dim PastePos: PastePos = GetPasteBasePos(ActSheet)
    
    '作業ｽﾀｰﾄ
    Dim OriPos
    Dim Sel As Selection
    Dim CloneView As DrawingView
    Dim CloneRngBox
    
    CATIA.HSOSynchronized = False
    Dim TmpSheet As DrawingSheet '一時作業用
    Set TmpSheet = GetNewDetailSheet()
    Do
        'ｺﾋﾟｰ要素選択
        Set Sel = SeledItems("ｺﾋﾟｰ要素選択 // [Esc]=ｷｬﾝｾﾙ")
        If KCL.IsNothing(Sel) Then Exit Do
        Sel.Copy
        
        '原点要素選択
        Do
            Set Sel = SeledItems("原点要素を選択 // [Esc]=ｺﾋﾟｰ要素再選択")
            If KCL.IsNothing(Sel) Then GoTo Continue
            
            OriPos = GetOrigin(Sel) '原点取得
            If IsEmpty(OriPos) Then
                Call SelectOriginErrMsg
            Else
                Exit Do
            End If
        Loop
        
        'ﾍﾟｰｽﾄ作業
        Set CloneView = GetCloneView(ActSheet, TmpSheet, OriPos)
        
        'ﾋﾞｭｰの移動
        CloneRngBox = GetViewRngBox(CloneView)
        CloneView.x = PastePos(0) + (CloneRngBox(0)(0) * -1)
        CloneView.y = PastePos(1) + (CloneRngBox(1)(1) * -1) - OFFSET
        
        'ﾍﾟｰｽﾄ位置更新
        PastePos(0) = PastePos(0) + OFFSET + _
                      (CloneRngBox(1)(0) - CloneRngBox(0)(0))
Continue:
    Loop
    CATIA.HSOSynchronized = True
    
    '一時的なﾃﾞｨﾃｰﾙｼｰﾄ削除
    With Doc.Selection
        .Clear
        .Add TmpSheet
        .Delete
    End With
End Sub

'原点取得
Private Function GetOrigin(ByVal Sel As Selection) As Variant
    GetOrigin = Empty
    Select Case Sel.Count2
        Case 0
            Exit Function
        Case 1
            GetOrigin = GetOrigin_Single(Sel.Item2(1).value)
        Case Else
            GetOrigin = GetOrigin_Multi( _
                            Array(Sel.Item2(1).value, _
                                  Sel.Item2(2).value))
    End Select
End Function

'原点取得-1個
Private Function GetOrigin_Single(ByVal Geo2D As Geometry2D) As Variant
    GetOrigin_Single = Empty
    
    Select Case Geo2D.GeometricType
        Case catGeoTypePoint2D '点
            GetOrigin_Single = toPos(Geo2D)
            
        Case catGeoTypeCircle2D '円弧
            GetOrigin_Single = toPos(Geo2D.CenterPoint)
        
    End Select
End Function

'原点取得-2個以上
Private Function GetOrigin_Multi(ByVal Geo2D As Variant) As Variant
    GetOrigin_Multi = Empty
    
    '直線ﾁｪｯｸ
    Dim i&
    For i = 0 To 1
        If Not (Geo2D(i).GeometricType = catGeoTypeLine2D) Then Exit Function
    Next
    
    '端点取得
    Dim St(1), Ed(1), Pos(1)
    For i = 0 To 1
        Call Geo2D(i).GetOrigin(Pos)
        St(i) = Pos
        Call Geo2D(i).GetDirection(Pos)
        Ed(i) = Sum2d(St(i), Pos)
    Next
    
    '交点取得
    Dim IntPos: IntPos = Intersect2d(St(0), Ed(0), St(1), Ed(1))
    If IsEmpty(IntPos) Then Exit Function
    
    GetOrigin_Multi = IntPos
End Function

'Point2Dから座標値取得
Private Function toPos(Pnt As Variant) As Variant
    Dim Pos(1): Call Pnt.GetCoordinates(Pos)
    toPos = Pos
End Function

'原点取得Ngﾒｯｾｰｼﾞ
Private Sub SelectOriginErrMsg()
    Dim Msg$
    Msg = "原点となる要素は" & vbNewLine & _
          "1個 - 点、円弧" & vbNewLine & _
          "2個 - 直線(平行な線はNG)" & vbNewLine & _
          "としてください"
    MsgBox Msg, vbOKOnly + vbInformation
End Sub

'ﾃﾞｨﾃｰﾙｼｰﾄ作成
Private Function GetNewDetailSheet() As DrawingSheet
    Dim Sheets As DrawingSheets: Set Sheets = CATIA.ActiveDocument.Sheets
    Dim Act As DrawingSheet: Set Act = Sheets.ActiveSheet
    Set GetNewDetailSheet = Sheets.AddDetail("AutomaticNaming")
    Act.Activate
End Function

'ﾍﾟｰｽﾄ
Private Function GetCloneView(ByVal TargetSheet As DrawingSheet, _
                              ByVal Detail As DrawingSheet, ByVal Origin)
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    
    'ﾃﾞｨﾃｰﾙｼｰﾄにﾍﾟｰｽﾄ
    Dim DetailView As DrawingView
    Set DetailView = Detail.Views.Add("AutomaticNaming")
    With Sel
        .Clear
        .Add DetailView
        .Paste
    End With
    
    'ﾍﾟｰｽﾄﾋﾞｭｰ
    Dim CloneView As DrawingView
    Set CloneView = TargetSheet.Views.Add("AutomaticNaming")
    
    'ｺﾝﾎﾟｰﾈﾝﾄ化-分解
    Dim Comp As DrawingComponent
    Set Comp = CloneView.Components.Add(DetailView, _
                                        Origin(0) * -1, Origin(1) * -1)
    Call Comp.Explode
    
    '不要ﾃﾞｰﾀ削除
    With Sel
        .Clear
        .Add DetailView
        .Delete
    End With
    
    Set GetCloneView = CloneView
End Function

'ﾍﾟｰｽﾄ基準位置
''' @return:array(long) 0-X, 1-Y
Private Function GetPasteBasePos(ByVal Sheet As DrawingSheet) As Variant
    Dim Vws As DrawingViews: Set Vws = Sheet.Views
    Dim ViewEnum As Collection: Set ViewEnum = InitRangeList(1, Vws.count)
    Call ViewEnum.Remove(2) '背景は無視
    
    Dim MinPos: MinPos = Array(DBL_MAX, DBL_MAX)
    Dim i, RngBox
    For Each i In ViewEnum
        RngBox = GetViewRngBox(Vws.Item(i))
        If MinPos(0) > RngBox(0)(0) Then MinPos(0) = RngBox(0)(0)
        If MinPos(1) > RngBox(0)(1) Then MinPos(1) = RngBox(0)(1)
    Next
    GetPasteBasePos = MinPos
End Function

'Viewのｻｲｽﾞ取得
''' @return:array(array(long),array(long)) 00-Xmin, 01-Ymin, 10-Xmax, 11-Ymax
Private Function GetViewRngBox(View) As Variant 'View As DrawingView)
    Dim Pos(4): Call View.Size(Pos)
    GetViewRngBox = Array(Array(Pos(0), Pos(2)), Array(Pos(1), Pos(3)))
End Function

'選択
''' @param:Msg-ﾒｯｾｰｼﾞ
''' @return:Selection
Private Function SeledItems(ByVal Msg$) As Selection
    Set SeledItems = Nothing
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement3(Array("Geometry2D"), Msg, True, _
                    CATMultiSelTriggWhenUserValidatesSelection, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SeledItems = Sel
End Function

'初期化済みｺﾚｸｼｮﾝ生成
Private Function InitRangeList(ByVal Min&, ByVal Max&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = Min To Max
        List.Add i
    Next
    Set InitRangeList = List
End Function

'*** math ***
'和2D
Private Function Sum2d(ByVal a, ByVal b) As Variant
    Sum2d = Array(a(0) + b(0), a(1) + b(1))
End Function

'差2D
Private Function Sub2d(ByVal a, ByVal b) As Variant
    Sub2d = Array(a(0) - b(0), a(1) - b(1))
End Function

'内積2D
Private Function Dot2d(ByVal a, ByVal b) As Double
    Dot2d = a(0) * b(0) + a(1) * b(1)
End Function

'外積2D
Private Function Cross2d(ByVal a, ByVal b) As Double
    Cross2d = a(0) * b(1) - a(1) * b(0)
End Function

'交点 a1-a2とb1-b2
Private Function Intersect2d(ByVal a1, ByVal a2, ByVal b1, ByVal b2)
    Intersect2d = Empty
    If isParallel(a1, a2, b1, b2) Then Exit Function
    Dim a: a = Sub2d(a2, a1)
    Dim b: b = Sub2d(b2, b1)
    Dim c#: c = Cross2d(b, Sub2d(b1, a1)) / Cross2d(b, a)
    a(0) = a(0) * c
    a(1) = a(1) * c
    Intersect2d = Sum2d(a1, a)
End Function

'丸め誤差を考慮し、公差を設けたイコール判定
Private Function EQ(ByVal a As Double, ByVal b As Double) As Boolean
    EQ = IIf(Abs((a) - (b)) < EPS, True, False)
End Function

'平行判定 a1-a2とb1-b2
Private Function isParallel(ByVal a1, ByVal a2, ByVal b1, ByVal b2) As Boolean
    isParallel = EQ(Cross2d(Sub2d(a1, a2), Sub2d(b1, b2)), 0#)
End Function

利用方法です。ｻﾝﾌﾟﾙﾃﾞｰﾀのDXFをｲﾝﾎﾟｰﾄした状態はこんな感じです。

これ、僕が作ったわけじゃないです。GrabCADのこちらをお借りしました。
GrabCAD - CAD library
今更ながら、ｻﾝﾌﾟﾙとしては現実味が無さすぎです･･･。

原点はこんなところにあります。

ﾏｸﾛ実行後、まずｺﾋﾟｰする要素を選択します。複数選択が可能なので
ﾗﾊﾞｰﾊﾞﾝﾄﾞやCtrlｷｰと併用して頂くと複数選択できます。

"ﾂｰﾙﾊﾟﾚｯﾄ" ﾂｰﾙﾊﾞｰが出てくるので、選択した状態のまま一番右の
"完了" ﾎﾞﾀﾝで決定です。

続いて原点となる要素の選択です。手順はｺﾋﾟｰする要素を選択と
同じなのですが、選択要素によって原点の決定方法が異なります。

○1個だけ選択
　・点 - 点の位置を原点とします。
　・円弧 - 円弧の中心を原点とします。

○2個以上を選択　（2個以上選択しても、最初の2個だけで判断します）
　・両方直線 - 交点を原点とします。

他の場合は、再度原点要素の指定となります。

原点決定後は、ｺﾋﾟﾍﾟ処理を行います。出来上がるﾋﾞｭｰは他のﾋﾞｭｰと
重ならないように、左下の位置から右側に順次ｺﾋﾟﾍﾟしていきます。

一度では終わらない事が多いため、ESCｷｰが入力されるまで繰り返されます。

これ、原点指定の2本の直線を選択した際、交差していなくても
交点を求めて、原点として設定してます。

こんな感じで選択し

こんな感じで原点指定の要素を選択すると

ｺﾋﾟﾍﾟされたﾋﾞｭｰでは、こんな感じになってます。

煩わしい原点合わせの操作が要らないんです。

念のためですが、3Dとﾘﾝｸしているﾃﾞｰﾀでは利用できません。
･･･必要ないでしょう。
又、2Dｺﾝﾎﾟｰﾈﾝﾄもｺﾋﾟﾍﾟ出来ません。事前に展開しておく必要が有ります。
こちらも全ての2Dｺﾝﾎﾟｰﾈﾝﾄを展開するﾏｸﾛをそのうちUpします。

追記
2Dｺﾝﾎﾟｰﾈﾝﾄを展開するﾏｸﾛは、こちらです。
2Dｺﾝﾎﾟｰﾈﾝﾄを展開する - C#ATIA

ArrayListﾗｯﾊﾟｰｸﾗｽをお借りしてみる

線形4分木ですが、どの様な形で返そうか?　空間の再分割が
つらいのでやめようか　等があり、ﾅｶﾅｶ進みません。

もう一つ悩んでいるのが、VBAのｺﾚｸｼｮﾝ。今更ですがｺﾚｸｼｮﾝの
Itemがﾌﾟﾛﾊﾟﾃｨではなく、ﾒｿｯﾄﾞになっていることに嫌気がさして
きたので他のものを使うことにします。

手頃そうなものを探したところ、こちらを見付けました。
AarrayListをvbaで使いやすいようにラップしてみた : 趣味のプログラムあれこれ

DotNetFrameworkのArrayListのﾗｯﾊﾟｰｸﾗｽです。
折角なのでﾃｽﾄしてみました。
(ｸﾗｽの名称が長かった為、cListとしています)

'vba test_ArrayList using-'KCL0.09'
'.NETFramework_ArrayList_Rapper_Class Test
'http://blog.livedoor.jp/midorityo/archives/50749809.html
Sub CATMain()
    Dim Lst As cList: Set Lst = New cList
    With Lst
        .Add 1
        .Add 10
        .Add 21
        .Add 21
        .Add -5
        .Add 3
    End With
    Call DumpList(Lst)
    
    'ｲﾝﾃﾞｸｻ NG
    'Debug.Print lst(1)
    
    '代入
    Lst.Item(0) = 100: Call DumpList(Lst)
    
    'Sort
    Call Lst.Sort: Call DumpList(Lst)
    
    'Reverse
    Call Lst.Reverse: Call DumpList(Lst)
    
    'BinarySearch
    Call DumpValue(Lst.BinarySearch(21), "Idx:")
    Call DumpValue(Lst.BinarySearch(2), "Idx:")
    
    'IndexOf
    Call DumpValue(Lst.IndexOf(21), "IndexOf:")
    Call DumpValue(Lst.IndexOf(2), "IndexOf:")
    
    'LastIndexOf
    Call DumpValue(Lst.LastIndexOf(21), "LastIndexOf:")
    Call DumpValue(Lst.LastIndexOf(2), "LastIndexOf:")
    
    'Contains
    Call DumpValue(Lst.Contains(21), "Contains:")
    Call DumpValue(Lst.Contains(2), "Contains:")
    
    'Insert
    Call Lst.Insert(1, 99): Call DumpList(Lst)
    
    'ToString
    Call DumpValue(Lst.ToString, "ToString")
    
    'TrinToSize
    Call DumpValue(Lst.capacity, "TrinToSize_Before:")
    Call Lst.TrinToSize
    Call DumpValue(Lst.capacity, "TrinToSize_After:")
    
    'Clear
    Call Lst.Clear: Call DumpList(Lst)
    
    'capacity
    Set Lst = New cList
    Call KCL.SW_Start
    Call DumpValue(Lst.capacity, "non_capacity:")
    Set Lst = InitRngList(Lst, 32766)
    Call DumpValue(KCL.SW_GetTime, , "s")
    
    Set Lst = New cList
    Call KCL.SW_Start
    Lst.capacity = 32767
    Call DumpValue(Lst.capacity, "use_capacity:")
    Set Lst = InitRngList(Lst, 32766)
    Call DumpValue(KCL.SW_GetTime, , "s")
End Sub

Private Function InitRngList(ByVal Lst As cList, ByVal count&) As cList
    Dim i&
    For i = 0 To count
        Lst.Add i
    Next
    Set InitRngList = Lst
End Function

Private Sub DumpList(ByVal Lst As cList)
    Debug.Print "---"
    For i = 0 To Lst.count - 1
        Debug.Print Lst.Item(i)
    Next
End Sub

Private Sub DumpValue(ByVal v, _
                      Optional ByVal msg_s$ = vbNullString, _
                      Optional ByVal msg_e$ = vbNullString)
    Debug.Print "---"
    Debug.Print msg_s & v & msg_e
End Sub

内容的には意味は無いのです。ｲﾝﾃﾞｸｻが無いのとForEach出来ない
部分がちょっと物足りないのですが、それ以上に不安を感じるのが
capacityの値が32767以上ではｵｰﾊﾞｰﾌﾛｰになってしまい、少なすぎる
気がしてます。(要素をAdd出来る最大数です)

"ForEach出来ない" 部分は、こちらを参考に修正してみましたがNG
でした。VBAのｺﾚｸｼｮﾝのみのお話なのでしょう。
(ArrayListｸﾗｽには、NewEnumがありません)

VBA 自作のCollectionクラスをFor Eachでまわす裏ワザ - t-hom’s diary

単純に考え、ArrayListを返すための "ToList" ﾒｿｯﾄﾞをｸﾗｽﾓｼﾞｭｰﾙに
追記しました。

Function ToList() As Variant
    Set ToList = arraylist
End Function

これであれば、こんな感じでForEach出来ます。

Private Sub DumpList(ByVal Lst As cList)
    Debug.Print "---"
    For Each v In Lst.ToList
        Debug.Print v
    Next
End Sub

そんな事を試しているうちに、こちらの記述を見つけました。
VBAのコレクションへの添え字によるアクセスを早くする - Qiita
ん～VBAｺﾚｸｼｮﾝのｷｰ付き(辞書型っぽい使い方)の呼び出しが
想像以上に速い。知らなかったです。
DotNetFrameworkのArrayListが遅いのは、C#をやっていた頃に
知りました。(現在はｼﾞｪﾈﾘｯｸｺﾚｸｼｮﾝがある為、基本ArrayListは
利用されていないはず）

で、気を取り直し試してみました。

Sub CATMain2()
    Dim Lst As cList: Set Lst = New cList

    Set Lst = New cList
    Call KCL.SW_Start
    Lst.capacity = 32767
    Set Lst = InitRngList(Lst, 32766)
    
    '--loop--
    'For
    Call KCL.SW_Start
    For i = 0 To Lst.count - 1: dmy = Lst(i): Next
    Call DumpValue(KCL.SW_GetTime, "For: ", "s")
    
    'ToArray_For
    Call KCL.SW_Start
    Ary = Lst.ToArray
    For i = 0 To UBound(Ary) - 1: dmy = Ary(i): Next
    Call DumpValue(KCL.SW_GetTime, "ToArray_For: ", "s")
    
    'ForEach
    Call KCL.SW_Start
    For Each v In Lst.ToList: dmy = v: Next
    Call DumpValue(KCL.SW_GetTime, "ForEach: ", "s")
    
    'ToList_ForEach
    Call KCL.SW_Start
    Set L = Lst.ToList
    For Each v In L: dmy = v: Next
    Call DumpValue(KCL.SW_GetTime, "ToList_ForEach: ", "s")
End Sub

cListを
・素の状態でFor
・ToArrayで代入してFor
・追記したToListをそのままForEach
・追記したToListを代入してからForEach
結果はこちら

---
For: 0.516s
---
ToArray_For: 0.003s
---
ForEach: 0.018s
---
ToList_ForEach: 0.018s

以前、"ForよりForEachの方が速い" と思っていたのですが、
VBAのｺﾚｸｼｮﾝをForをするのが遅いのであって、For自体は速いんですね。

capacityが小さいから、配列とｺﾚｸｼｮﾝと併用しようかな。
(かなりわかりにくくなりそう)

Space-eﾈｲﾃｨﾌﾞﾌｧｲﾙをSatﾌｧｲﾙにD&Dで変換するｽﾌﾟﾘｸﾄ

ｲﾛｲﾛと紆余曲折ありまして、Space-eをﾊﾞｰｼﾞｮﾝｱｯﾌﾟしVer5.5が
使える事になりました。　時間が無いのであまり触っていませんが。

僕は予定が無いのですが、Space-eﾈｲﾃｨﾌﾞﾌｧｲﾙ(.mdp)をACISﾌｧｲﾙに
変換したいと言うお話が社内にありまして、どうせならCADの
ｵﾍﾟﾚｰｼｮﾝを奪われないように、ﾊﾞｯﾁ処理で変換する方法が無いものか
と思い、ｻﾎﾟｰﾄに問い合わせたのですが　"出来ません"　との
回答を頂きました。(Space-eはACISｶｰﾈﾙです)

"そんな事、無いだろう" と思い、ｲﾝｽﾄｰﾙﾌｫﾙﾀﾞ内を検索したところ･･･
ごめんなさい、ｱｯｻﾘ見付けてしまいました。

このままではちょっと使いにくい為、D&Dして変換できるような
VBｽﾌﾟﾘｸﾄを作成してみました。
変換を行う実行ﾌｧｲﾙまでのﾊﾟｽは、各PC毎に設定する必要があります。
(M2S_PATH定数です)
又、当然ながらﾗｲｾﾝｽは必要です。

'vbs mdp2sat.vbs
'Space-eVer5.5 D&Dでmdp→sat変換するｽﾌﾟﾘｸﾄ ver0.0.2
Option Explicit

'*************************
'PC毎に設定-ﾃﾞﾌｫﾙﾄｲﾝｽﾄｰﾙであれば変更不要
Private Const M2S_PATH = "C:\HZS\Modeler\dmu\bin\MdpToSat.exe"
'*************************
'設定-ｲｼﾞﾗﾅｲﾃﾞ
Private Const PROSFOLDRNAME = "心当たりがない場合は削除してください" '作業ﾌｫﾙﾀﾞ名
Private Const BATCHHAEDER = "このﾌｧｲﾙはﾊﾞｯﾁ確認用のﾌｧｲﾙです。心当たりがない場合は削除して結構です。"
Private Const DAMMYFILENAME = "temp.txt" 'ﾀﾞﾐｰﾌｧｲﾙ名
Private Const FILENAMEFOOTER = "_Layer_" '変換ﾌｧｲﾙﾌｯﾀｰ
'*************************

Call Main

Sub Main()
    'D&D
    Dim Args: Set Args = WScript.Arguments
    If Not Drop(Args) Then Exit Sub
    
    'Speﾁｪｯｸ
    If Not IsSpacee Then Exit Sub
    
    'Mdpﾌｧｲﾙﾌｨﾙﾀ
    Dim MdpAry: MdpAry = GetMdpFileAry(Args)
    If IsEmpty(MdpAry) Then
        MsgBox "Mdpﾌｧｲﾙがありませんでした"
        Exit Sub
    End If
    
    '作業ﾌｫﾙﾀﾞ(削除ﾁｪｯｸ用)
    Dim ProcessFolder: ProcessFolder = GetProcessFolderName(Args(0))
    
    '作業中ﾁｪｯｸ
    If Not CanExecute(ProcessFolder) Then Exit Sub
    
    '変換後ﾌｧｲﾙ名取得
    Dim SatAry: SatAry = GetSatName(MdpAry)
    
    '変換ﾊﾞｯﾁｺｰﾄﾞ取得
    Dim ConvCodes: ConvCodes = GetConvertCode(MdpAry, SatAry, ProcessFolder)
    
    '作業ﾌｫﾙﾀﾞ作成 ﾀﾞﾐｰ作成
    Call GetFSO.CreateFolder(ProcessFolder)
    Call CreateDammyFile(ProcessFolder)
    
    'ﾊﾞｯﾁﾌｧｲﾙ作成 - 実行
    Call BatchExecute(ConvCodes, ProcessFolder)
    
    'ﾀﾞﾐｰ削除
    Call GetFSO.DeleteFile(ProcessFolder & "\" & DAMMYFILENAME)
    
    'ﾊﾞｯﾁ終了ﾁｪｯｸ
    Dim Fd: Set Fd = GetFSO.GetFolder(ProcessFolder)
    Do
        WScript.Sleep 100
        If Fd.Files.Count < 1 Then Exit Do
    Loop
    
    '作業ﾌｫﾙﾀﾞ削除
    Call GetFSO.DeleteFolder(ProcessFolder)
    
    '終了
    MsgBox "元ﾌｧｲﾙ " & CStr(UBound(MdpAry) + 1) & "個分のﾌｧｲﾙを変換しました"
End Sub

'Space-eﾁｪｯｸ
Private Function IsSpacee()
    IsSpacee = IsExists(M2S_PATH)
    If Not IsSpacee Then
        MsgBox M2S_PATH & vbNewLine & _
               "が見つかりません。　ﾊﾟｽを再設定してください"
    End If
End Function

'実行
Private Sub BatchExecute(ByVal Codes, ByVal ProsPath)
    Dim Cnt: Cnt = UBound(Codes)
    Dim Ws: Set Ws = CreateObject("WScript.Shell")
    Dim i, Path
    For i = 0 To Cnt
        Path = ProsPath & "\" & CStr(i) & ".bat"
        Call WriteFile(Path, Codes(i))
        Ws.Run Path
    Next
    Set Ws = Nothing
End Sub

'ﾀﾞﾐｰ作成
Private Sub CreateDammyFile(ByVal Path)
    Call WriteFile(Path & "\" & DAMMYFILENAME, BATCHHAEDER)
End Sub

'変換ﾊﾞｯﾁｺｰﾄﾞ
Private Function GetConvertCode(ByVal MdpAry, ByVal SatAry, ByVal ProsPath)
    Dim Cnt: Cnt = UBound(MdpAry)
    Dim Codes(): ReDim Codes(Cnt)
    Dim Path
    Dim i
    For i = 0 To Cnt
        Path = SplitPathName(SatAry(i))
        Codes(i) = "rem " & BATCHHAEDER & vbNewLine & _
                   "mkdir " & Path(0) & vbNewLine & _
                   M2S_PATH & " " & MdpAry(i) & " " & SatAry(i) & vbNewLine & _
                   "del " & ProsPath & "\" & CStr(i) & ".bat"
    Next
    GetConvertCode = Codes
End Function

'変換後ﾌｧｲﾙ名
Private Function GetSatName(ByVal MdpAry)
    Dim Cnt: Cnt = UBound(MdpAry)
    Dim SatAry(): ReDim SatAry(Cnt)
    Dim i
    For i = 0 To Cnt
        SatAry(i) = GetNewFolderName(GetRemoveExtensionPath(MdpAry(i)) & ".sat")
    Next
    GetSatName = SatAry
End Function

'作業ﾌｫﾙﾀﾞﾊﾟｽ取得
Private Function GetProcessFolderName(ByVal Path)
    Dim TmpPath: TmpPath = SplitPathName(Path)
    GetProcessFolderName = TmpPath(0) & "\" & PROSFOLDRNAME
End Function

'実行確認
Private Function CanExecute(ByVal Path)
    Dim Exi: Exi = IsExists(Path)
    If Exi Then
        Dim Msg
        Msg = "変換の処理中の可能性があります。" & vbNewLine & _
              "変換処理が終了してから再度行ってください。" & vbNewLine & _
              "万一、変換処理が終了している場合は、手動で" & vbNewLine & _
              "「" & Path & "」" & vbNewLine & _
              "フォルダを削除してください。"
        MsgBox Msg
    End If
    CanExecute = Not Exi
End Function

'Mdpﾘｽﾄ
Private Function GetMdpFileAry(ByVal InAry)
    GetMdpFileAry = Empty
    Dim ExAry(): ReDim ExAry(InAry.Count)
    Dim Cnt: Cnt = -1
    Dim i, Path, Ext
    For i = 0 To InAry.Count - 1
        Path = SplitPathName(InAry(i))
        Ext = UCase(Path(2))
        If Ext = "MDP" And IsExists(InAry(i)) Then
            Cnt = Cnt + 1
            ExAry(Cnt) = InAry(i)
        End If
    Next
    If Cnt < 0 Then Exit Function
    ReDim Preserve ExAry(Cnt)
    GetMdpFileAry = ExAry
End Function

'ﾄﾞﾛｯﾌﾟ
Private Function Drop(List)
    If List.Count = 0 Then
        Dim Msg
        Msg = "MdpﾌｧｲﾙをD&Dしてください"
        MsgBox Msg
        Drop = False
    Else
        Drop = True
    End If
End Function

'*** IO ***
'FSO
Private Function GetFSO()
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'ﾌｧｲﾙ有無
Private Function IsExists(ByVal Path)
    IsExists = False
    Dim FSO: Set FSO = GetFSO
    If FSO.FileExists(Path) Then
        IsExists = True 'ﾌｧｲﾙ
    ElseIf FSO.FolderExists(Path) Then
        IsExists = True 'ﾌｫﾙﾀﾞ
    End If
    Set FSO = Nothing
End Function

'ﾌｧｲﾙ名
Private Function SplitPathName(ByVal FullPath)
    Dim Path(2)
    Dim FSO: Set FSO = GetFSO
    With FSO
        Path(0) = .GetParentFolderName(FullPath)
        Path(1) = .GetBaseName(FullPath)
        Path(2) = .GetExtensionName(FullPath)
    End With
    SplitPathName = Path
    Set FSO = Nothing
End Function

'書き出し
Private Sub WriteFile(ByVal Path, ByVal Txt)
    Call GetFSO.OpenTextFile(Path, 2, True).Write(Txt)
End Sub

'重複しない名前取得 拡張子は新しいもので投げて
Private Function GetNewFolderName(ByVal OldPath)
    Dim Path: Path = SplitPathName(OldPath)
    Dim NewPath: NewPath = Path(0) & "\" & Path(1)
    Dim TempName: TempName = NewPath
    If Not IsExists(TempName) Then
        GetNewFolderName = TempName & "\" & Path(1) & FILENAMEFOOTER & "." & Path(2)
        Exit Function
    End If
    Dim i: i = 0
    Do
        i = i + 1
        TempName = NewPath + "_" & CStr(i)
        If Not IsExists(TempName) Then
            GetNewFolderName = TempName & "\" & Path(1) & FILENAMEFOOTER & "." & Path(2)
            Exit Function
        End If
    Loop
End Function

'拡張子無しのﾊﾟｽ
Private Function GetRemoveExtensionPath(ByVal Path)
    Dim TmpPath: TmpPath = SplitPathName(Path)
    GetRemoveExtensionPath = TmpPath(0) & "\" & TmpPath(1)
End Function

'*************************
'ver0.0.1 17.01.13 完成
'ver0.0.2 17.01.16 Space-eﾁｪｯｸ追加 各ﾌｧｲﾙをﾌｫﾙﾀﾞ内に変換
'*************************

上記のｺｰﾄﾞを拡張子 "vbs" のﾌｧｲﾙ名で保存して頂いて、Space-eﾈｲﾃｨﾌﾞﾌｧｲﾙ
をD&Dして頂ければ、D&Dしたﾌｧｲﾙと同一ﾌｫﾙﾀﾞ内にﾌｧｲﾙと同じ名前の
ﾌｫﾙﾀﾞを製作した上でSatﾌｧｲﾙに変換します。(複数ﾌｧｲﾙをD&DしてもOKです)

但し、ちょっとｲﾏｲﾁなんです。　変換後のﾌｧｲﾙは各ｸﾗｽ(ﾚｲﾔｰ・ﾚﾍﾞﾙ)毎に
なってしまい、大量のﾌｧｲﾙになってしまいます。
(これ以上の方法がわかりません)

と、ここまではSpace-eﾕｰｻﾞｰ以外は興味も湧かないお話です。

ここからは、自分自身で忘れてしまいそうなので覚書です。
上記のｺｰﾄﾞは複数ﾌｧｲﾙの同時変換した後に　"終わったよ" とﾀﾞｲｱﾛｸﾞを
表示させています。　つまりﾊﾞｯﾁ処理の終了を認識しています。
(要は、外部ﾌﾟﾛｸﾞﾗﾑの終了を認識しています)

ﾊﾞｯﾁ処理の終了を認識する方法は、他にもあるだろうと思いますが
以下の方法で行っています。

まず、WScript.ArgumentsでD&Dされた全ﾌｧｲﾙﾊﾟｽを取得します。
続いて作業用の一時ﾌｫﾙﾀﾞを作成し、ちょっと訳があってﾀﾞﾐｰﾌｧｲﾙを
一時ﾌｫﾙﾀﾞ内に作成します。

その後、一時ﾌｫﾙﾀﾞ内に全ﾌｧｲﾙ数分の変換用ﾊﾞｯﾁﾌｧｲﾙを作成し、
即、実行させています。　ﾊﾞｯﾁﾌｧｲﾙの中身はこんな感じです。
(ﾌｧｲﾙ名は 0.bat と仮定しておきます)

rem このﾌｧｲﾙはﾊﾞｯﾁ確認用のﾌｧｲﾙです。心当たりがない場合は削除して結構です。
mkdir C\temp\hoge
C:\HZS\Modeler\dmu\bin\MdpToSat.exe C\temp\hoge.mdp C\temp\hoge\hoge_Layer_.sat
del C\temp\心当たりがない場合は削除してください\0.bat

最後の行ですが、自分自身を削除するようになっています。これにより
変換終了後はﾊﾞｯﾁﾌｧｲﾙも削除されます。

続いて先程の "訳ありﾀﾞﾐｰﾌｧｲﾙ" を削除し、一時ﾌｫﾙﾀﾞ内のﾌｧｲﾙ数を
0.1秒おきに監視します。　ﾌｧｲﾙ数が0となれば全ての変換が終了して
いる事になる為、一時ﾌｫﾙﾀﾞを削除し終了となります。

実はこの "訳ありﾀﾞﾐｰﾌｧｲﾙ" を作成しないと、処理が速すぎる為なのか
上手く動作しなかったんですよ。こちらでも同様の手法です。
Space-e D&Dでﾌｧｲﾙ変換するｽﾌﾟﾘｸﾄ - C#ATIA

ｲﾝﾌﾟﾛｾｽ実行時、一部をｱｳﾄﾌﾟﾛｾｽで実行 2

こちらの続きです。
ｲﾝﾌﾟﾛｾｽ実行時、一部をｱｳﾄﾌﾟﾛｾｽで実行 - C#ATIA

呼び出すだけではなく、戻り値も取得できるものか?　確認して
いなかったので前回のｺｰﾄﾞを修正し、ﾃｽﾄすることにしました。

'vba using-'KCL0.09'
Sub CATMain()
    '*** VBE準備 ***
    Dim VbPjName$: VbPjName = "Using_KCL_Sample"    'ﾌﾟﾛｼﾞｪｸﾄ名
    Dim VbCpName$: VbCpName = "Test_Func_Evaluate"  'ﾓｼﾞｭｰﾙ名
    Dim VbFcName$: VbFcName = "SelCrv"              '関数名

    'VBE
    Dim Vbe As Object: Set Vbe = GetVBE()
    If KCL.IsNothing(Vbe) Then Exit Sub
    
    'VBProject
    Dim Pj As Object: Set Pj = GetVBProject(VbPjName, Vbe)
    If KCL.IsNothing(Pj) Then Exit Sub
    
    'VBComponent
    Dim Cp As Object: Set Cp = GetVBComponent(VbCpName, Pj)
    If KCL.IsNothing(Cp) Then Exit Sub
    
    'CodeModule
    Dim Cm As Object: Set Cm = Cp.CodeModule
    
    'Component内のｺｰﾄﾞ取得
    Dim Code$: Code = GetCode(VbFcName, Cm)
    If Code = vbNullString Then Exit Sub

    '*** CATIA ***
    '選択
    Dim Hb As HybridBody: Set Hb = KCL.SelectItem("Select", "HybridBody")
    If KCL.IsNothing(Hb) Then Exit Sub
    
    '実行言語
    Dim SLang As CATScriptLanguage: SLang = CATVBALanguage
    
    '引数
    Dim Prm(0) As Variant: Set Prm(0) = Hb
    
    'SystemService
    Dim SS As Variant: Set SS = CATIA.SystemService
    
    '呼出し
    Dim Cnt&: Cnt = SS.Evaluate(Code, SLang, VbFcName, Prm)
    
    MsgBox "Select Count : " & Cnt
End Sub

'ｱｳﾄﾌﾟﾛｾｽ用ﾏｸﾛ - PrivateNG
Function SelCrv(Prm)
    Dim Hb As HybridBody
    Set Hb = Prm
    
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    
    Dim HS As HybridShape
    For Each HS In Hb.HybridShapes
        Sel.add HS
    Next
    SelCrv = Sel.Count2
End Function

・・・

残りの部分は前回と同じままです。
外部ﾏｸﾛとして呼び出している "SelCrv" を選択後のｱｲﾃﾑ数を
返すようにし、最後に受け取ったｱｲﾃﾑ数を表示するようにしました。

実行結果はこんな感じです

無事、戻り値は受け取れます。Functionも有効なんですね。
さらに表示できていると言うことは、外部で呼び出した処理が終わる
まで待機していることが確認できます。(投げっぱなしじゃない)

但し、"Private Function" ではNGなんです。
好みと言うより、お作法としては可能な限りｽｺｰﾌﾟを小さくしたい
ので、ちょっと困ります。
最悪、ｺｰﾄﾞを文字列として取得してから実行までのﾀｲﾑﾗｸﾞがあるので
"Private Function" でｺｰﾄﾞを書き、実行前に "Private" を削除して
しまうしか無いのかな?

又、昨年末から今年にかけてｿｰﾄ処理をｺﾞﾆｮｺﾞﾆｮ書いていた件も、
この方法で条件となる部分のｺｰﾄﾞを書き換えて、実行しても可能な
気がしているのですが…、ｿｰﾄ処理程度でここまですべきものか
疑問。