怎么打断啊？我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多
怎么打断啊？我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多多指教，再此谢谢啦！我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多多指教，再此谢谢啦！ 莫人知道啊？ 打断是采用AutoCAD内部的命令，在交点处断开，因而关键的问题是找到相交的对象，以及交点的坐标，这个可以通过IntersectWith函数来判断。代码如下：
Sub test()
Dim SSetObj As AcadSelectionSet
Dim EntObj As AcadEntity
Dim Pt1 As Variant
Dim Pt2 As Variant
Dim i As Integer
Dim Pt As Variant
Dim bPt(0 To 1) As Double
On Error Resume Next
'创建选择集
Set SSetObj = ThisDrawing.SelectionSets("test")
If Err Then
Err.Clear
Set SSetObj = ThisDrawing.SelectionSets.Add("test")
End If
On Error GoTo ErrTrap
For Each EntObj In ThisDrawing.ModelSpace
SSetObj.Clear
'选择与指定对象最小最大范围相交的对象
EntObj.GetBoundingBox Pt1, Pt2
SSetObj.Select acSelectionSetCrossing, Pt1, Pt2
For i = 0 To SSetObj.Count - 1
'选中了自身对象时，不进行操作
If SSetObj(i).Handle <> EntObj.Handle Then
Pt = EntObj.IntersectWith(SSetObj(i), acExtendNone)
If Not IsEmpty(Pt) Then
For j = 0 To UBound(Pt) Step 3
bPt(0) = Pt(j)
bPt(1) = Pt(j + 1)
ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & EntObj.Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
Next
End If
End If
Next
Next
Exit Sub
ErrTrap:
On Error GoTo 0
End Sub
终于有人回帖子了，欣喜ing~~~~~~~~~~
谢谢大虾，我这就试试看！ 这个问题可能没这么简单，因为：
断开后对象会变成两个对象，而程序的继操作只是对断开后的一个对象进行操作，而新生成的对象不做操作。但如果考虑新生成的对象，则这种操作就会变成很多的循环。这也是难点。
我想能不能先不要断开，而只取得每个对象上的断开点，再根据对象的属性重新生成对象，这样可能工作量会大点，而且对于某些对象可能不太适合，如样条曲线。
如果能够从末端开始进行断开操作，则下一个断开点还可以保留在源对象上，这可能可行，但这些点怎样排序，又是一个问题。 明总提示有理，我的图就是船体剖面图，所以涉及到样条曲线，是不好生成的。 要对点进行排序，必须使用到曲线类模块并计算每一点到线起点的距离，再进行排序，然后再进行打断。思路应该是这个思路。 没有学过曲线类模块，我是学船的。不过上边efan2000版主的程序我试过了，可以划断，谢谢大家！ <p>我也很想知道如何容易的实现，也在探索</p> <p>可以先找到交点，把交点坐标形成数组。然后在每个交点处选择周围的对象，将每个对象打断于交点。</p><p>找交点我用的是两两相交的办法，如果一个交点有两个以上对象，会有重复。希望有人能给出更好的方法。</p><p>对填充和块参照无法打断。</p><p>Sub 交点处相互打断()<br/> On Error Resume Next<br/> Dim ssetObj As AcadSelectionSet<br/> '创建选择集<br/> Set ssetObj = ThisDrawing.SelectionSets("test")<br/> If Err Then<br/> Err.Clear<br/> Set ssetObj = ThisDrawing.SelectionSets.Add("test")<br/> End If<br/> ssetObj.Clear '首先清空选择集<br/> ssetObj.Select acSelectionSetAll<br/> <br/>' 取得交点<br/> Dim i As Long<br/> Dim j As Long<br/> Dim k As Long<br/> Dim pt As Variant<br/> Dim points() As Double<br/> Dim N As Long<br/> N = 0<br/> For i = 0 To ssetObj.Count - 1<br/> For j = i + 1 To ssetObj.Count - 1<br/> pt = ssetObj(i).IntersectWith(ssetObj(j), acExtendNone)<br/> If UBound(pt) >= 2 Then<br/> ReDim Preserve points(N + UBound(pt)) '逐步定义数组，需要关键字<br/> For k = 0 To UBound(pt)<br/> points(N + k) = pt(k)<br/> Next<br/> N = N + UBound(pt) + 1<br/> End If<br/> Next<br/> Next<br/> <br/> '交点处打断<br/> Dim bpt(0 To 2) As Double<br/> Dim ss As AcadSelectionSet<br/> Set ss = ThisDrawing.SelectionSets("dog")<br/> If Err Then<br/> Err.Clear<br/> Set ss = ThisDrawing.SelectionSets.Add("dog")<br/> End If<br/> For i = 0 To UBound(points) Step 3<br/> bpt(0) = points(i)<br/> bpt(1) = points(i + 1)<br/> bpt(2) = points(i + 2)<br/> ss.Clear<br/> SelectAtPoint ss, bpt<br/> For k = 0 To ss.Count - 1<br/> ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & ss(k).Handle & """)" & vbCr & bpt(0) & "," & bpt(1) & vbCr & "@" & vbCr<br/> Next<br/> Next<br/>End Sub<br/></p><p>' 选择通过某点的实体<br/>Public Sub SelectAtPoint(ByRef SSet As AcadSelectionSet, ByVal pt As Variant)<br/> ' 构造一个以pt为中心的小矩形作为选择范围<br/> Dim pt1 As Variant, pt2 As Variant<br/> Dim objUtility As Object<br/> Set objUtility = ThisDrawing.Utility ' 必须使用后期绑定<br/> objUtility.CreateTypedArray pt1, vbDouble, pt(0) - 0.0001, pt(1) - 0.0001, pt(2)<br/> objUtility.CreateTypedArray pt2, vbDouble, pt(0) + 0.0001, pt(1) + 0.0001, pt(2)<br/> <br/> SSet.Select acSelectionSetCrossing, pt1, pt2<br/>End Sub<br/></p>
页:
[1]