[原创]曲线打断于交点

雪山飞狐_lzh · 发表于 2005-1-6 19:19:00

<CommandMethod("TlsSB")> Public Shared Sub TlsSelectionSetBreak() Dim ss As TlsSelectionSet
Dim objIds As ObjectIdCollection
Dim objs As New ObjectIdCollection
Dim i, j As ObjectId
Dim k As Point3d
Dim oCurve, pCurve As Curve
Dim pnts, dots As Point3dCollection
Dim pTM As New TlsTM pTM.StartTrans()
Try
pTM.OpenBlockTableRecord(BlockTableRecord.ModelSpace) ss = New TlsSelectionSet("TlsSel")
ss.SetFilter(0, "Line,Arc,Circle,Ellipse,Spline,Lwpolyline")
ss.SelectObjectOnScreen()
objIds = ss.ToObjectIdCollection For Each i In objIds
pnts = New Point3dCollection
oCurve = i.Open(OpenMode.ForRead, False, True) For Each j In objIds
dots = New Point3dCollection
If i.OldId <> j.OldId Then
pCurve = j.Open(OpenMode.ForRead, False, True)
oCurve.IntersectWith(pCurve, Intersect.OnBothOperands, dots, 0, 0)
For Each k In dots
pnts.Add(k)
Next
pCurve.Close()
End If
Next pTM.SortPnts(oCurve, pnts)
If Not (oCurve.Closed And pnts.Count = 1) Then
objs.Add(i)
pTM.Add(oCurve.GetSplitCurves(pnts))
End If
oCurve.Close()
Next pTM.Remove(objs) pTM.CommitTrans()
Catch ex As Exception
Finally
pTM.Dispose()
End Try End Sub

雪山飞狐_lzh · 发表于 2005-1-6 19:19:00

Imports Autodesk.AutoCAD.ApplicationServices Imports Autodesk.AutoCAD.DatabaseServices Imports Autodesk.AutoCAD.Runtime Imports Autodesk.AutoCAD.Interop Imports Autodesk.AutoCAD.Interop.Common Imports Autodesk.AutoCAD.Geometry

Public Class TlsSelectionSet Private m_oSel As AcadSelectionSet Private m_vFilterType() As Short, m_vFilterData() As Object Private m_sName As String Private m_oApp As AcadApplication = Application.AcadApplication Private m_oDoc As AcadDocument

Public Sub NullFilter() '清空过滤器

 m_vFilterType = Nothing m_vFilterData = Nothing

 End Sub

 Private Function IsNull() As Boolean

 If m_oSel Is Nothing Then IsNull = True ElseIf m_oSel.Count = 0 Then IsNull = True Else IsNull = False End If

 End Function Public Sub New() Me.New("TlsSel") End Sub

 Public Sub New(ByVal Name As String) m_oDoc = m_oApp.ActiveDocument Init(Name) End Sub Public Sub Init(ByVal Name As String) '创建选择集

 NullFilter() If Not m_oSel Is Nothing Then m_oSel.Delete() m_sName = Name Try m_oDoc.SelectionSets.Item(m_sName).Delete() Catch ex As Exception

 End Try m_oSel = m_oDoc.SelectionSets.Add(m_sName)

 End Sub

 Protected Overrides Sub Finalize() MyBase.Finalize() If Not m_oSel Is Nothing Then m_oSel.Delete() End Sub

 Public ReadOnly Property Count() As Integer '获取选择集实体个数 Get Count = m_oSel.Count End Get End Property

 Public ReadOnly Property Name() As String '获取选择集名称 Get Name = m_sName End Get End Property

 Public ReadOnly Property Item(ByVal Index) As AcadEntity '获取选择集实体 Get Item = m_oSel.Item(Index) End Get End Property

 Public Sub AddItem(ByVal obj As AcadEntity) '向选择集加入单个实体

 Dim objs(0) As AcadEntity

 objs(0) = obj m_oSel.AddItems(objs)

 End Sub

 Public Sub AddItem(ByVal objs As AcadEntity()) '向选择集加入实体数组

 m_oSel.AddItems(objs)

 End Sub

 Public Sub RemoveItem(ByVal obj As AcadEntity) '在选择集中移除单个实体

 Dim objs(0) As AcadEntity objs(0) = obj m_oSel.RemoveItems(objs)

 End Sub

 Public Sub RemoveItem(ByVal objs As AcadEntity()) '在选择集中移除实体数组

 m_oSel.RemoveItems(objs)

 End Sub

 Public Sub Clear() '清空选择集

 Select Case m_sName Case "

ICKFIRST" GetPickfirstSelectionSet() Case "CURRENT" GetActiveSelectionSet() Case Else Init(m_sName) End Select

 m_oSel.Clear()

 End Sub

 Public Sub Update()

 m_oSel.Update()

 End Sub

 Public Sub GetPickfirstSelectionSet() '获取Pickfirst选择集

 NullFilter() If Not m_oSel Is Nothing Then m_oSel.Delete() m_sName = "

ICKFIRST" m_oDoc.SelectionSets.Item(m_sName).Delete() m_oSel = m_oDoc.PickfirstSelectionSet

 End Sub

 Public Sub GetActiveSelectionSet() '获取Active选择集 On Error Resume Next

 NullFilter() If Not m_oSel Is Nothing Then m_oSel.Delete() m_sName = "CURRENT" m_oDoc.SelectionSets.Item(m_sName).Delete() m_oSel = m_oDoc.ActiveSelectionSet

 End Sub

 Public Sub SetFilterType(ByVal ParamArray FilterType()) '设置过滤器类型

 Dim i Dim nCount As Short nCount = UBound(FilterType) ReDim m_vFilterType(nCount)

 For i = 0 To nCount m_vFilterType(i) = FilterType(i) Next i

 End Sub

 Public Sub SetFilterData(ByVal ParamArray FilterData()) '设置过滤器数据

 Dim i Dim nCount As Integer nCount = UBound(FilterData) ReDim m_vFilterData(nCount)

 For i = 0 To nCount m_vFilterData(i) = FilterData(i) Next i

 End Sub

 Public Sub SetFilter(ByVal ParamArray Filter()) '设置过滤器

 Dim i Dim n As Integer Dim nCount As Integer nCount = (UBound(Filter) + 1) / 2 - 1 ReDim m_vFilterType(nCount), m_vFilterData(nCount)

 For i = 0 To nCount n = i * 2 m_vFilterType(i) = Filter(n) m_vFilterData(i) = Filter(n + 1) Next i

 End Sub

 Public Sub SelectObjectOnScreen()

 If IsArray(m_vFilterType) Then m_oSel.SelectOnScreen(m_vFilterType, m_vFilterData) Else m_oSel.SelectOnScreen() End If

 End Sub

 Public Sub SelectObject(ByVal Mode As AcSelect, ByVal Point1 As Object, ByVal Point2 As Object)

 If IsArray(m_vFilterType) Then m_oSel.Select(Mode, Point1, Point2, m_vFilterType, m_vFilterData) Else m_oSel.Select(Mode, Point1, Point2) End If

 End Sub Public Sub SelectObject(ByVal Mode As AcSelect)

 If IsArray(m_vFilterType) Then m_oSel.Select(Mode, , , m_vFilterType, m_vFilterData) Else m_oSel.Select(Mode) End If

 End Sub

 Public Sub SelectObjectAtPoint(ByVal Point) On Error Resume Next

 If IsArray(m_vFilterType) Then m_oSel.SelectAtPoint(Point, m_vFilterType, m_vFilterData) Else m_oSel.SelectAtPoint(Point) End If

 End Sub

 Public Sub SelectObjectByPolygon(ByVal Mode As AcSelect, ByVal Points As Object)

 If IsArray(m_vFilterType) Then m_oSel.SelectByPolygon(Mode, Points, m_vFilterType, m_vFilterData) Else m_oSel.SelectByPolygon(Mode, Points) End If

 End Sub

 Public WriteOnly Property Visible() As Boolean Set(ByVal Value As Boolean) If IsNull() Then Exit Property

 Dim i As AcadEntity For Each i In m_oSel i.Visible = Value Next i End Set End Property

 Public WriteOnly Property Layer() As String Set(ByVal Value As String)

 If IsNull() Then Exit Property

 Dim i As AcadEntity For Each i In m_oSel i.Layer = Value Next i End Set End Property

 Public WriteOnly Property LineType() As String Set(ByVal Value As String)

 If IsNull() Then Exit Property

 Dim i As AcadEntity For Each i In m_oSel i.Linetype = Value Next i End Set End Property

 Public WriteOnly Property Color() As ACAD_COLOR Set(ByVal Value As ACAD_COLOR)

 If IsNull() Then Exit Property

 Dim i As AcadEntity For Each i In m_oSel i.color = Value Next i End Set End Property

 Public Sub Move(ByVal Point1 As Object, ByVal Point2 As Object)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.Move(Point1, Point2) Next i

 End Sub

 Public Function Copy(ByVal Point1 As Object, ByVal Point2 As Object) As AcadEntity()

 If IsNull() Then Exit Function

 Dim objs() As AcadEntity Dim i ReDim objs(Count - 1)

 For i = 0 To Count objs(i) = m_oSel.Item(i).Copy objs(i).Move(Point1, Point2) Next i

 Return objs

 End Function

 Public Sub Rotate(ByVal BasePoint As Object, Optional ByVal RotationAngle As Double = 1.0#)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.Rotate(BasePoint, RotationAngle) Next i

 End Sub

 Public Sub Rotate3D(ByVal Point1 As Object, ByVal Point2 As Object, Optional ByVal RotationAngle As Double = 1.0#)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.Rotate3D(Point1, Point2, RotationAngle) Next i

 End Sub

 Public Sub ScaleAll(ByVal BasePoint As Object, Optional ByVal ScaleFactor As Double = 1)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.ScaleEntity(BasePoint, ScaleFactor) Next i

 End Sub

 Public Sub Mirror(ByVal Point1 As Object, ByVal Point2 As Object)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.Mirror(Point1, Point2) Next i

 End Sub

 Public Sub Mirror3D(ByVal Point1 As Object, ByVal Point2 As Object, ByVal Point3 As Object)

 If IsNull() Then Exit Sub

 Dim i As AcadEntity For Each i In m_oSel i.Mirror3D(Point1, Point2, Point3) Next i

 End Sub

 Public Sub Highlight(Optional ByVal HighlightFlag As Boolean = True)

 Dim i As AcadEntity For Each i In m_oSel i.Highlight(HighlightFlag) Next i

 End Sub

 Public Sub Delete()

 m_oSel.Erase()

 End Sub

 Public Sub CopyObjects(ByVal Owner As Object, ByVal IdPairs As Object)

 If IsNull() Then Exit Sub

 m_oDoc.CopyObjects(ToArray, Owner, IdPairs)

 End Sub

 Public Sub CopyObjects(ByVal Owner As Object)

 If IsNull() Then Exit Sub

 m_oDoc.CopyObjects(ToArray, Owner)

 End Sub

 Public Sub CopyObjects()

 If IsNull() Then Exit Sub

 m_oDoc.CopyObjects(ToArray)

 End Sub

 Public Function GetBoundingBox(ByRef MinPoint As Object, ByRef MaxPoint As Object) As Boolean

 Dim i Dim d1, d2, p1, p2

 If IsNull() Then Exit Function

 m_oSel.Item(0).GetBoundingBox(d1, d2)

 For i = 1 To Count - 1

 m_oSel.Item(i).GetBoundingBox(p1, p2)

 If p1(0) < d1(0) Then d1(0) = p1(0) If p1(1) < d1(1) Then d1(1) = p1(1) If p2(0) > d2(0) Then d2(0) = p2(0) If p2(1) > d2(1) Then d2(1) = p2(1)

 Next i

 MinPoint = d1 MaxPoint = d2

 End Function

 Public Function ToBlock(ByVal InsertionPoint As Object, Optional ByVal Name As String = "*U") As String

 If IsNull() Then Exit Function

 Dim oBlock As AcadBlock oBlock = m_oDoc.Blocks.Add(InsertionPoint, Name) CopyObjects(oBlock)

 Return oBlock.Name

 End Function

 Public Function ToSelectionSet() As AcadSelectionSet '获取选择集

 Return m_oSel

 End Function

 Public Function ToArray() '转化选择集为对象数组输出

 Dim i Dim objs() As AcadEntity Dim nCount As Integer

 nCount = m_oSel.Count - 1 ReDim objs(nCount)

 For i = 0 To nCount objs(i) = m_oSel.Item(i) Next i

 Return objs

 End Function

 Public Function ToObjectIdCollection() As ObjectIdCollection '转化选择集为对象数组输出 Dim i Dim objId As ObjectId Dim objs As New ObjectIdCollection For i = 0 To m_oSel.Count - 1 objId.OldId = m_oSel.Item(i).ObjectID objs.Add(objId) Next i

 Return objs

 End Function

 End Class

雪山飞狐_lzh · 发表于 2005-1-6 19:20:00

Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Interop
Imports Autodesk.AutoCAD.Geometry
Imports AutoCadTM = Autodesk.AutoCAD.DatabaseServices.TransactionManager Public Class TlsTM
Private pDatabase As Database
Private pTransactionManager As AutoCadTM
Private pStartTransaction As Transaction
Private pBlockTable As BlockTable
Private pBlockTableRecord As BlockTableRecord '程序功能：向当前块表记录中加入实体
Public Function Add(ByVal TlsEntity As DBObject) pBlockTableRecord.AppendEntity(TlsEntity)
pTransactionManager.AddNewlyCreatedDBObject(TlsEntity, True) End Function '程序功能：向当前块表记录中加入实体数组
Public Function Add(ByVal TlsEntity As DBObject()) Dim i As DBObject
For Each i In TlsEntity
Add(i)
Next i End Function Public Function Add(ByVal TlsEntity As DBObjectCollection) Dim i As DBObject
For Each i In TlsEntity
Add(i)
Next i End Function Public Sub Remove(ByVal ObjId As ObjectId) Dim oEntity As Entity
oEntity = ObjId.Open(OpenMode.ForWrite, True, True)
oEntity.Erase(True)
oEntity.Close() End Sub Public Sub Remove(ByVal ObjIds As ObjectIdCollection) Dim i As ObjectId
For Each i In ObjIds
Remove(i)
Next End Sub '程序功能：生成一个新块，并加入实体
Public Function AddBlock(ByVal Name As String, ByVal Entitys As DBObject()) As ObjectId
Dim i As DBObject
Dim pDatabase As Database = Application.DocumentManager.MdiActiveDocument.Database
Dim pTransactionManager As AutoCadTM = pDatabase.TransactionManager
Dim pStartTransaction As Transaction = pTransactionManager.StartTransaction()
Try Dim pBlockTable As BlockTable = CType(pTransactionManager.GetObject(pDatabase.BlockTableId, OpenMode.ForWrite, False), BlockTable)
Dim pBlockTableRecord As New BlockTableRecord
pBlockTableRecord.Name = Name
pBlockTable.Add(pBlockTableRecord)
Dim pId As ObjectId = pBlockTableRecord.Id For Each i In Entitys
pBlockTableRecord.AppendEntity(i)
pTransactionManager.AddNewlyCreatedDBObject(i, True)
Next i pBlockTableRecord.Close()
pBlockTable.Close()
pStartTransaction.Commit() Return pId Finally
pStartTransaction.Dispose()
End Try End Function '开始事务
Public Sub StartTrans() pDatabase = Application.DocumentManager.MdiActiveDocument.Database
pTransactionManager = pDatabase.TransactionManager
pStartTransaction = pTransactionManager.StartTransaction() End Sub '打开一个块表记录
Public Sub OpenBlockTableRecord(ByVal str As String) pBlockTable = CType(pTransactionManager.GetObject(pDatabase.BlockTableId, OpenMode.ForRead, False), BlockTable)
pBlockTableRecord = CType(pTransactionManager.GetObject(pBlockTable(str), OpenMode.ForWrite, False), BlockTableRecord) End Sub '事务提交
Public Sub CommitTrans() pBlockTableRecord.Close()
pBlockTable.Close()
pStartTransaction.Commit() End Sub '事务结束
Public Sub Dispose() pStartTransaction.Dispose()
pBlockTableRecord = Nothing
pBlockTable = Nothing
pStartTransaction = Nothing
pTransactionManager = Nothing
pDatabase = Nothing End Sub
'获取当前的辅助工具
Public Function Utility() As AcadUtility Return Application.AcadApplication.ActiveDocument.Utility End Function '曲线上的点排序
Public Sub SortPnts(ByVal TlsCurve As Curve, ByRef TlsPnts As Point3dCollection) Dim i, j As Short
Dim nCount As Short
Dim pTmp As Point3d
nCount = TlsPnts.Count
For i = 1 To nCount - 1
For j = 0 To nCount - i - 1
Try
If TlsCurve.GetDistAtPoint(TlsPnts(j)) > TlsCurve.GetDistAtPoint(TlsPnts(j + 1)) Then
pTmp = TlsPnts(j)
TlsPnts.RemoveAt(j)
TlsPnts.Insert(j + 1, pTmp)
End If
Catch ex As Exception
End Try
Next
Next End Sub
Public Function AddLine(ByVal pointer1() As Double, ByVal pointer2() As Double) As Line Dim pLine As Line
pLine = New Line( _
New Point3d(pointer1(0), pointer1(1), pointer1(2)), _
New Point3d(pointer2(0), pointer2(1), pointer2(2))) Add(pLine)
Return pLine End Function
End Class

账号		自动登录	找回密码
密码			注册

[原创]曲线打断于交点

浏览过的版块