こちらの続きです。
2D曲線の折れ線化 - ｽﾌﾟﾗｲﾝ - C#ATIA
2DCADであれば比較的、重複線削除の機能を持ったものもあると思います。
AutoCADであればこんな機能です。
OVERKILL[重複オブジェクト削除] (コマンド) | AutoCAD | Autodesk Knowledge Network
僕が使用しているAdvanceCADでも機能は有るのですが、完全に一致して
いなければ "重複線" と判断されず、削除されないんです、AutoCADは
知りませんが。(極端な話 0.00000001mm ｽﾞﾚていても削除されません)
3Dな時代なので、恐らく現実的には寸法指定の無い部分であれば、大まかな
形状のﾗｲﾝさえ図面に存在していれば良いような気がしています。(違いますか?)
完全に一致していないものでも "不要だよ" と思われる線が図面内には
結構な量が存在していませんかね?
それを考えると、やはりﾄﾚﾗﾝｽを考慮した重複線削除の機能が欲しいんです。
個人的には。(要は見た目で影響ない範囲で、ﾃﾞｰﾀを軽くしたい)
2D円弧と2Dｽﾌﾟﾗｲﾝ折れ線化を利用し、指定したﾋﾞｭｰ内の重複線を
探し出し、選択した状態で終了するﾃｽﾄﾏｸﾛです。
説明不足な上、重複ﾁｪｯｸがほぼ総当りに近い状態な為、使い物には
なりませんが、後に修正したものとの比較の為に掲載します。
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"
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
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
Lst.Add Line2Poly(Geo)
Case catGeoTypeCircle2D
Lst.Add Circle2Poly(Geo)
Case Else
Lst.Add Curve2Poly(Geo)
End Select
Next
Set GetPolyList = Lst
End Function
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
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))
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&)
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
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
Private Function ArcCos(ByVal V As Double) As Double
ArcCos = Atn(-V / Sqr(-V * V + 1)) + 2 * Atn(1)
End Function
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
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
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
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
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
Private Function Dot2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
Dot2d = V1(0) * V2(0) + V1(1) * V2(1)
End Function
Private Function Cross2d(ByVal V1 As Variant, ByVal V2 As Variant) As Double
Cross2d = V1(0) * V2(1) - V1(1) * V2(0)
End Function
Private Function InitRangeList(ByVal Count&) As Collection
Dim List As Collection: Set List = New Collection
Dim i&
For i = 1 To Count
List.Add i
Next
Set InitRangeList = List
End Function
Private Sub Q_ISort_List(ByRef IdxList As Collection, ByVal LngList As Collection)
Dim THREASHOLD&: THREASHOLD = 16
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
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
試してはいないのですが、始点ﾊﾟﾗﾒｰﾀ・終点ﾊﾟﾗﾒｰﾀ・ﾄﾚﾗﾝｽ を指定してやれば、
ﾄﾚﾗﾝｽ以内で折れ線化するための点群が、恐らく得られる関数だと思います。
最初に見付けたとき、羨ましくてしょうがなかったです。
