読者です 読者をやめる 読者になる 読者になる

C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

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をインポートした状態はこんな感じです。
f:id:kandennti:20170120185124p:plain
これ、僕が作ったわけじゃないです。GrabCADのこちらをお借りしました。
GrabCAD - CAD library
今更ながら、サンプルとしては現実味が無さすぎです・・・。

原点はこんなところにあります。
f:id:kandennti:20170120185131p:plain


マクロ実行後、まずコピーする要素を選択します。複数選択が可能なので
ラバーバンドやCtrlキーと併用して頂くと複数選択できます。
f:id:kandennti:20170120185140p:plain
"ツールパレット" ツールバーが出てくるので、選択した状態のまま一番右の
"完了" ボタンで決定です。


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

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

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

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


原点決定後は、コピペ処理を行います。出来上がるビューは他のビューと
重ならないように、左下の位置から右側に順次コピペしていきます。
f:id:kandennti:20170120185152p:plain

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


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

こんな感じで選択し
f:id:kandennti:20170120185201p:plain

こんな感じで原点指定の要素を選択すると
f:id:kandennti:20170120185209p:plain

コピペされたビューでは、こんな感じになってます。
f:id:kandennti:20170120185215p:plain

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


念のためですが、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" を選択後のアイテム数を
返すようにし、最後に受け取ったアイテム数を表示するようにしました。

実行結果はこんな感じです
f:id:kandennti:20170113125207p:plain

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

但し、"Private Function" ではNGなんです。
好みと言うより、お作法としては可能な限りスコープを小さくしたい
ので、ちょっと困ります。
最悪、コードを文字列として取得してから実行までのタイムラグがあるので
"Private Function" でコードを書き、実行前に "Private" を削除して
しまうしか無いのかな?


又、昨年末から今年にかけてソート処理をゴニョゴニョ書いていた件も、
この方法で条件となる部分のコードを書き換えて、実行しても可能な
気がしているのですが…、ソート処理程度でここまですべきものか
疑問。