[原创]曲线打断于交点

雪山飞狐_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 "PICKFIRST" 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 = "PICKFIRST" 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

页: [1]

明经CAD社区's Archiver

[原创]曲线打断于交点