[原创]曲线打断于交点
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.OldIdj.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
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)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
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]