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

chpmould

看贴必顶，回贴是一种美德...

empire4794

不要让它沉下去了，我自己顶个先~~

dianbotang

看你的附件，图层B与自身相交也会在交点处被打断。请楼主说明清楚。

dianbotang

适用于交点处仅有两条相关线条，按附件要求编程如下，请检验：

Sub 交点处等间距打断2()
  On Error Resume Next
 
  Dim Ent1 As AcadEntity, Pnt1 As Variant
  Dim Ent2 As AcadEntity, Pnt2 As Variant
  ThisDrawing.Utility.GetEntity Ent1, Pnt1, "选择一个对象用于打断："
  If Err Then Exit Sub
  ThisDrawing.Utility.GetEntity Ent2, Pnt2, "选择一个被打断的对象："
  If Err Then Exit Sub
  Dim Layer1 As String
  Dim Layer2 As String
  Layer1 = Ent1.Layer
  Layer2 = Ent2.Layer
 
  Dim fType(0) As Integer  ' 过滤器规则
  Dim fData(0) As Variant  ' 过滤器参数
  fType(0) = 8
  fData(0) = Layer1 & "," & Layer2
 
  Dim SSfish As AcadSelectionSet
  '创建选择集
  Set SSfish = ThisDrawing.SelectionSets("fish")
  If Err Then
      Err.Clear
      Set SSfish = ThisDrawing.SelectionSets.Add("fish")
  End If
  SSfish.Clear '首先清空选择集
  SSfish.SelectOnScreen fType, fData
 
  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 SSfish.Count - 2
    For j = i + 1 To SSfish.Count - 1
      pt = SSfish(i).IntersectWith(SSfish(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 SSdog As AcadSelectionSet
  Set SSdog = ThisDrawing.SelectionSets("dog")
  If Err Then
      Err.Clear
      Set SSdog = ThisDrawing.SelectionSets.Add("dog")
  End If
  Dim SSpig As AcadSelectionSet
  Set SSpig = ThisDrawing.SelectionSets("pig")
  If Err Then
      Err.Clear
      Set SSpig = ThisDrawing.SelectionSets.Add("pig")
  End If
  Dim BreakObj As AcadEntity
  For i = 0 To UBound(points) Step 3
    bpt(0) = points(i)
    bpt(1) = points(i + 1)
    bpt(2) = points(i + 2)
    SSdog.Clear
    SelectAtPoint SSdog, bpt
    SSpig.Clear
    SSpig.Select acSelectionSetPrevious, , , fType, fData
    If SSpig.Count <> 2 Then Exit Sub
    Set circleObj = ThisDrawing.ModelSpace.AddCircle(bpt, jianju / 2)
    If SSpig(0).Layer = Layer1 And SSpig(1).Layer = Layer2 Then
      Set BreakObj = SSpig(1)
    ElseIf SSpig(0).Layer = Layer2 And SSpig(1).Layer = Layer1 Then
      Set BreakObj = SSpig(0)
    ElseIf SSpig(0).Layer = Layer2 And SSpig(1).Layer = Layer2 Then
      Set BreakObj = SSpig(1) '自行设定
    Else
      GoTo 10
    End If
    cpt = BreakObj.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(BreakObj) & vbCr & axPoint2lspPoint(cpt1) & vbCr & axPoint2lspPoint(cpt2) & vbCr
    End If
10:
    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

楼上的程序运行后还是无反应。哪位高手弄个好用的程序吧~~

dianbotang

把三条红线选择出来，只对其进行操作，可以满足你的要求。

注意操作顺序：

先选择用于打断别的线条的线条，再选择被打断的线条，然后框选所有线条，最后输入打断间距（比如7），回车就行了。

还不行的话建议上传完整的文件，便于分析。你请求别人帮忙，总得相信别人吧。

empire4794

程序所要达到的效果流程图如附件所示.

empire4794

附件见18楼.

dianbotang

楼主的意图早就明白了，其实问题很好解决的。

上面程序可以实现楼主的要求，只是还有些细节的问题楼主没有表达清楚，可以根据你的意图进行微调。

比如图层A用于打断图层B，如果图层A的两条线相交需不需要打断？

程序的用法我应该已经讲清楚了。

楼主的附件红线白线在一个图层，实际情况应该不是这样。

不明白楼主为何不把你真正的原件上传，早传早解决嘛，我看了你的文件对我又没有任何好处。

把我的邮箱也留下，愿意的话发到我邮箱吧。

tongmingniao@163.com

empire4794

楼上的dianbotang兄弟，上面的附件只是一个流程示意图，红线和白线虽然是在一个图层画的，

但是我是要表示两个不同的图层，只是为了方便就没有另外建立图层来画。

图层A的两条线相交要不要打断是可以设置的，是或否，流程图里也有说明可选择。

说到原件，针对这个问题我没有原件。这个问题是因为在平时做图的时候经常要用BREAK命令来

一个一个的打断多条相交的线很麻烦，所以就想请哪位高手能弄个这样的程序，以便减少绘图中的

烦琐。