怎么打断啊？我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多

freshair

怎么打断啊？我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多多指教，再此谢谢啦！[br]我想在图纸上把所有的线条在交点处打断，不知道怎么实现。请各位高手多多指教，再此谢谢啦！

freshair

莫人知道啊？

efan2000

打断是采用AutoCAD内部的命令，在交点处断开，因而关键的问题是找到相交的对象，以及交点的坐标，这个可以通过IntersectWith函数来判断。
代码如下：

2. Sub test()
   
3.     Dim SSetObj As AcadSelectionSet
   
4.     Dim EntObj As AcadEntity
   
5.     Dim Pt1 As Variant
   
6.     Dim Pt2 As Variant
   
7.     Dim i As Integer
   
8.     Dim Pt As Variant
   
9.     Dim bPt(0 To 1) As Double
   
10.    
    
11.     On Error Resume Next
    
12.     '创建选择集
    
13.     Set SSetObj = ThisDrawing.SelectionSets("test")
    
14.     If Err Then
    
15.         Err.Clear
    
16.         Set SSetObj = ThisDrawing.SelectionSets.Add("test")
    
17.     End If
    
18.     On Error GoTo ErrTrap
    
19.     For Each EntObj In ThisDrawing.ModelSpace
    
20.         SSetObj.Clear
    
21.         '选择与指定对象最小最大范围相交的对象
    
22.         EntObj.GetBoundingBox Pt1, Pt2
    
23.         SSetObj.Select acSelectionSetCrossing, Pt1, Pt2
    
24.         For i = 0 To SSetObj.Count - 1
    
25.             '选中了自身对象时，不进行操作
    
26.             If SSetObj(i).Handle <> EntObj.Handle Then
    
27.                 Pt = EntObj.IntersectWith(SSetObj(i), acExtendNone)
    
28.                 If Not IsEmpty(Pt) Then
    
29.                     For j = 0 To UBound(Pt) Step 3
    
30.                         bPt(0) = Pt(j)
    
31.                         bPt(1) = Pt(j + 1)
    
32.                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & EntObj.Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
    
33.                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
    
34.                     Next
    
35.                 End If
    
36.             End If
    
37.         Next
    
38.     Next
    
39.     Exit Sub
    
40.    
    
41. ErrTrap:
    
42.     On Error GoTo 0
    
43. End Sub
    

Sub test()<br />     Dim SSetObj As AcadSelectionSet<br />     Dim EntObj As AcadEntity<br />     Dim Pt1 As Variant<br />     Dim Pt2 As Variant<br />     Dim i As Integer<br />     Dim Pt As Variant<br />     Dim bPt(0 To 1) As Double<br />     <br />     On Error Resume Next<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 />     On Error GoTo ErrTrap<br />     For Each EntObj In ThisDrawing.ModelSpace<br />         SSetObj.Clear<br />         '选择与指定对象最小最大范围相交的对象<br />         EntObj.GetBoundingBox Pt1, Pt2<br />         SSetObj.Select acSelectionSetCrossing, Pt1, Pt2<br />         For i = 0 To SSetObj.Count - 1<br />             '选中了自身对象时，不进行操作<br />             If SSetObj(i).Handle <> EntObj.Handle Then<br />                 Pt = EntObj.IntersectWith(SSetObj(i), acExtendNone)<br />                 If Not IsEmpty(Pt) Then<br />                     For j = 0 To UBound(Pt) Step 3<br />                         bPt(0) = Pt(j)<br />                         bPt(1) = Pt(j + 1)<br />                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & EntObj.Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr<br />                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr<br />                     Next<br />                 End If<br />             End If<br />         Next<br />     Next<br />     Exit Sub<br />     <br /> ErrTrap:<br />     On Error GoTo 0<br /> End Sub<br />

freshair

终于有人回帖子了，欣喜ing~~~~~~~~~~
谢谢大虾，我这就试试看！

mccad

这个问题可能没这么简单，因为：
断开后对象会变成两个对象，而程序的继操作只是对断开后的一个对象进行操作，而新生成的对象不做操作。但如果考虑新生成的对象，则这种操作就会变成很多的循环。这也是难点。
我想能不能先不要断开，而只取得每个对象上的断开点，再根据对象的属性重新生成对象，这样可能工作量会大点，而且对于某些对象可能不太适合，如样条曲线。
如果能够从末端开始进行断开操作，则下一个断开点还可以保留在源对象上，这可能可行，但这些点怎样排序，又是一个问题。

freshair

明总提示有理，我的图就是船体剖面图，所以涉及到样条曲线，是不好生成的。

mccad

要对点进行排序，必须使用到曲线类模块并计算每一点到线起点的距离，再进行排序，然后再进行打断。思路应该是这个思路。

freshair

没有学过曲线类模块，我是学船的。不过上边efan2000版主的程序我试过了，可以划断，谢谢大家！

tjdxtm

我也很想知道如何容易的实现，也在探索

dianbotang

可以先找到交点，把交点坐标形成数组。然后在每个交点处选择周围的对象，将每个对象打断于交点。

找交点我用的是两两相交的办法，如果一个交点有两个以上对象，会有重复。希望有人能给出更好的方法。

对填充和块参照无法打断。

Sub 交点处相互打断()
  On Error Resume Next
  Dim ssetObj As AcadSelectionSet
  '创建选择集
  Set ssetObj = ThisDrawing.SelectionSets("test")
  If Err Then
      Err.Clear
      Set ssetObj = ThisDrawing.SelectionSets.Add("test")
  End If
  ssetObj.Clear '首先清空选择集
  ssetObj.Select acSelectionSetAll
 
'  取得交点
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim pt As Variant
  Dim points() As Double
  Dim N As Long
  N = 0
  For i = 0 To ssetObj.Count - 1
    For j = i + 1 To ssetObj.Count - 1
      pt = ssetObj(i).IntersectWith(ssetObj(j), acExtendNone)
      If UBound(pt) >= 2 Then
        ReDim Preserve points(N + UBound(pt)) '逐步定义数组，需要关键字
        For k = 0 To UBound(pt)
          points(N + k) = pt(k)
        Next
        N = N + UBound(pt) + 1
      End If
    Next
  Next
 
  '交点处打断
  Dim bpt(0 To 2) As Double
  Dim ss As AcadSelectionSet
  Set ss = ThisDrawing.SelectionSets("dog")
  If Err Then
      Err.Clear
      Set ss = ThisDrawing.SelectionSets.Add("dog")
  End If
  For i = 0 To UBound(points) Step 3
    bpt(0) = points(i)
    bpt(1) = points(i + 1)
    bpt(2) = points(i + 2)
    ss.Clear
    SelectAtPoint ss, bpt
    For k = 0 To ss.Count - 1
        ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & ss(k).Handle & """)" & vbCr & bpt(0) & "," & bpt(1) & vbCr & "@" & vbCr
    Next
  Next
End Sub

' 选择通过某点的实体
Public Sub SelectAtPoint(ByRef SSet As AcadSelectionSet, ByVal pt As Variant)
    ' 构造一个以pt为中心的小矩形作为选择范围
    Dim pt1 As Variant, pt2 As Variant
    Dim objUtility As Object
    Set objUtility = ThisDrawing.Utility    ' 必须使用后期绑定
    objUtility.CreateTypedArray pt1, vbDouble, pt(0) - 0.0001, pt(1) - 0.0001, pt(2)
    objUtility.CreateTypedArray pt2, vbDouble, pt(0) + 0.0001, pt(1) + 0.0001, pt(2)
   
    SSet.Select acSelectionSetCrossing, pt1, pt2
End Sub