[求助]很多相交线快速打断

empire4794

在做图的时候，经常有很多线相交（直线与直线相交，弧线与弧线相交，PL线与PL线相交等），每次都要一个一个的

去打断非常不方便。

请问各位高手们，有没有一个程序运行后，能够自动打断相交的线：

1：能够设定要打断的相交线的图层（如：某个层和某个层间的相交线才打断，其他的不打断）

2：打断距离可以设置

3：是打断水平线还是打断垂直的线是可以设定的（此项功能也可不要）

dianbotang

先提供一个交点处等距打断的vba程序，可根据需要来改进。

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 jianju As Double
  jianju = ThisDrawing.Utility.GetReal("指定打断间距：")
  If Err Then Exit Sub
 
'  取得交点
  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 - 2
    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 circleObj As AcadCircle
  Dim cpt As Variant
  Dim cpt1(2) As Double
  Dim cpt2(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
    Set circleObj = ThisDrawing.ModelSpace.AddCircle(bpt, jianju / 2)
    For k = 0 To ss.Count - 1
      cpt = ss(k).IntersectWith(circleObj, acExtendNone)
      If UBound(cpt) = 5 Then
        cpt1(0) = cpt(0)
        cpt1(1) = cpt(1)
        cpt1(2) = cpt(2)
        cpt2(0) = cpt(3)
        cpt2(1) = cpt(4)
        cpt2(2) = cpt(5)
        ThisDrawing.SendCommand "_break" & vbCr & axEnt2lspEnt(ss(k)) & vbCr & axPoint2lspPoint(cpt1) & vbCr & axPoint2lspPoint(cpt2) & vbCr
      End If
    Next
    circleObj.Delete
  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
' 转换点的函数
Public Function axPoint2lspPoint(ByVal pnt As Variant) As String
    axPoint2lspPoint = pnt(0) & "," & pnt(1) & "," & pnt(2)
End Function
' 转换图元函数
Public Function axEnt2lspEnt(ByVal entObj As AcadEntity) As String
    Dim entHandle As String
    entHandle = entObj.Handle
    axEnt2lspEnt = "(handent " & Chr(34) & entHandle & Chr(34) & ")"
End Function

empire4794

2楼的程序如何调用？

dianbotang

empire4794发表于2009-6-9 12:22:002楼的程序如何调用？

很初级的问题啊。

工具-宏-vb编辑器，粘贴上述代码。返回cad窗口。

工具-宏-宏，运行即可。

empire4794

二楼的程序把相交的两条线都打断了，我只需要打断其中一根。

这程序估计会使所有相交的线都打断，不能只打断指定图层的线。

期待高手解答

empire4794

请liminnet老兄提供个程序吧~

dianbotang

应该不会太难，在上面程序的基础上加一个判断图层的条件语句即可。

希望楼主上传一个附件，并详细说明要求。

要编出合适的程序需要对操作过程和目标有详细的了解。

empire4794

附件中有要达到的效果示意图和要求，请各位大虾帮帮忙