C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

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

CATIA_V5 VBA KCL

こちらの続きです。
2D曲線の折れ線化 - ｽﾌﾟﾗｲﾝ - C#ATIA


2DCADであれば比較的、重複線削除の機能を持ったものもあると思います。
AutoCADであればこんな機能です。
OVERKILL[重複オブジェクト削除] (コマンド) | AutoCAD | Autodesk Knowledge Network

僕が使用しているAdvanceCADでも機能は有るのですが、完全に一致して
いなければ "重複線" と判断されず、削除されないんです、AutoCADは
知りませんが。(極端な話 0.00000001mm ｽﾞﾚていても削除されません)

3Dな時代なので、恐らく現実的には寸法指定の無い部分であれば、大まかな
形状のﾗｲﾝさえ図面に存在していれば良いような気がしています。(違いますか?)

完全に一致していないものでも "不要だよ" と思われる線が図面内には
結構な量が存在していませんかね?

それを考えると、やはりﾄﾚﾗﾝｽを考慮した重複線削除の機能が欲しいんです。
個人的には。(要は見た目で影響ない範囲で、ﾃﾞｰﾀを軽くしたい)



2D円弧と2Dｽﾌﾟﾗｲﾝ折れ線化を利用し、指定したﾋﾞｭｰ内の重複線を
探し出し、選択した状態で終了するﾃｽﾄﾏｸﾛです。

説明不足な上、重複ﾁｪｯｸがほぼ総当りに近い状態な為、使い物には
なりませんが、後に修正したものとの比較の為に掲載します。

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

Option Explicit

'*** 設定 ***
Private Const POLY_TOL = 0.1        '折れ線化ﾄﾚﾗﾝｽ
Private Const OVER_TOL = 0.001      '重複判断ﾄﾚﾗﾝｽ
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 ** :" & 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"
    
    '列挙用ｿｰﾄ
    Dim EnumLst As Collection: Set EnumLst = InitRangeList(CrvLst.Count)
    Call Q_ISort_List(EnumLst, LngLst)
    Debug.Print "EnumLst- " & EnumLst.Count & "個 : " & KCL.SW_GetTime & "s"
    
    '重複線Idx取得
    Dim OverLst As Collection: Set OverLst = GetOverlapList(EnumLst, PolyLst)
    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(IdxList As Collection, PolyList As Collection) As Collection
    Set GetOverlapList = Nothing

    Dim i&, j&
    Dim List As Collection: Set List = New Collection
    
    For i = 1 To IdxList.Count '重複線を判断する側(長いほうの線)
        For j = i + 1 To IdxList.Count '重複線を判断される側
            If IsOverlap(PolyList(IdxList(i)), PolyList(IdxList(j))) Then
                List.Add IdxList(j)
            End If
        Next
    Next
    Set GetOverlapList = List
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 '終点座標
    'Dim Lng# '長さ
    
    'ｽﾌﾟﾗｲﾝ情報
    Call Geo.GetEndPoints(Pos)
    StPos = Array(Pos(0), Pos(1))
    EnPos = Array(Pos(2), Pos(3))
    
    '折れ線化
    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)
        
        '分割点作成　距離チェック
        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
        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_V_P(Normaliz2d(A, B), C) 'ここ前回と変更した
    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))
    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

'長さ順の列挙用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

最近、ｺｰﾄﾞが長すぎる･･･ﾌﾞﾛｸﾞに掲載するには限界を超えている気がします。

折れ線化ﾄﾚﾗﾝｽ と 重複判断ﾄﾚﾗﾝｽ の2つのﾄﾚﾗﾝｽを持たせているのは、
以前に作った際、悩んだ末の名残です。

ﾋﾞｭｰに線が265本と3955本あるﾃﾞｰﾀで、折れ線化するまでの処理を
折れ線化ﾄﾚﾗﾝｽ 0.1 と 0.001 で試した結果がこちらです。

- 265本 -
** Obj Start ** :
POLY_TOL-0.1 : OVER_TOL-0.001
CrvLst- 265個 : 0.143s
RngLst- 265個 : 0.187s
LngLst- 265個 : 0.268s
PolyLst- 265個 : 0.584s
EnumLst- 265個 : 0.598s

** Obj Start ** :
POLY_TOL-0.001 : OVER_TOL-0.001
CrvLst- 265個 : 0.143s
RngLst- 265個 : 0.187s
LngLst- 265個 : 0.272s
PolyLst- 265個 : 3.092s
EnumLst- 265個 : 3.104s


- 3955本 -
** Obj Start ** :
POLY_TOL-0.1 : OVER_TOL-0.001
CrvLst- 3955個 : 2.008s
RngLst- 3955個 : 2.643s
LngLst- 3955個 : 3.953s
PolyLst- 3955個 : 16.375s
EnumLst- 3955個 : 18.51s

** Obj Start ** :
POLY_TOL-0.001 : OVER_TOL-0.001
CrvLst- 3955個 : 2.054s
RngLst- 3955個 : 2.711s
LngLst- 3955個 : 4.029s
PolyLst- 3955個 : 221.812s
EnumLst- 3955個 : 223.93s

折れ線化ﾄﾚﾗﾝｽ(POLY_TOL)を 0.001mmにすると、一気に処理時間が増えます。
原因は曲線の折れ線化のｱﾙｺﾞﾘｽﾞﾑの悪さです。　が、これ以上の良い方法が
わかりません。


Fusion360だと、こんな関数があるんですよ。
Help
試してはいないのですが、始点ﾊﾟﾗﾒｰﾀ・終点ﾊﾟﾗﾒｰﾀ・ﾄﾚﾗﾝｽ を指定してやれば、
ﾄﾚﾗﾝｽ以内で折れ線化するための点群が、恐らく得られる関数だと思います。
最初に見付けたとき、羨ましくてしょうがなかったです。