选择多义线或块引用则把通过框内线打断的程序

subtlation

在efan那个打断线交点的程序上改的。
只对于方形块引用和多义线有效。而且速度比较慢。
对于通过块应用的多义线，也无效。
以上不知道如何解决。望高手指点。

主程序

2. Sub blkTrim()
   
3. On Error Resume Next
   
4.   Dim ent As AcadEntity
   
5.   Dim sset As AcadSelectionSet
   
6.   Set sset = CreateSelectionSet("sset")
   
7.   Dim fType, fData As Variant
   
8.   BuildFilter fType, fData, 0, "INSERT"
   
9.   ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下块，若直接回车，则可选择多义线。"
   
10.   sset.SelectOnScreen fType, fData
    
11.   If sset.Count = 0 Then
    
12.     ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下多义线。"
    
13.     BuildFilter fType, fData, 0, "*Polyline"
    
14.     sset.SelectOnScreen fType, fData
    
15.     If sset.Count = 0 Then Exit Sub
    
16.   End If
    
17.   
    
18.   For Each ent In sset
    
19.     entTrimF ent
    
20.   Next
    
21.   
    
22.   sset.Delete
    
23.   
    
24. End Sub
    
25. 
    
26. 
    
27. Sub entTrimF(entobj As AcadEntity)
    
28.     Dim SSetObj As AcadSelectionSet
    
29.     Dim Pt1 As Variant
    
30.     Dim Pt2 As Variant
    
31.     Dim i As Integer
    
32.     Dim Pt, pnt1 As Variant
    
33.     Dim bPt(0 To 1) As Double
    
34.    
    
35.    
    
36.     On Error Resume Next
    
37.     '创建选择集
    
38.     Set SSetObj = CreateSelectionSet("ss1")
    
39.     Err.Clear
    
40.     entobj.GetBoundingBox Pt1, Pt2
    
41.    
    
42.   '要截断2次才能保证都截断完成
    
43.   For k = 0 To 1
    
44.     SSetObj.Select acSelectionSetCrossing, Pt1, Pt2
    
45.     '从集合中删除自身实体
    
46.     ssDelete SSetObj, entobj
    
47.     If SSetObj.Count = 0 Then GoTo ErrTrap
    
48.         For i = 0 To SSetObj.Count - 1
    
49.             '选中了自身对象时，不进行操作
    
50.             If SSetObj(i).Handle <> entobj.Handle Then
    
51.                 Pt = entobj.IntersectWith(SSetObj(i), acExtendNone)
    
52.                 If Not IsEmpty(Pt) Then
    
53.                     For j = 0 To UBound(Pt) Step 3
    
54.                         bPt(0) = Pt(j)
    
55.                         bPt(1) = Pt(j + 1)
    
56.                         ThisDrawing.SendCommand "_break" & vbCr & "(handent """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
    
57.                     Next j
    
58.                 End If
    
59.             End If
    
60.         Next i
    
61.      SSetObj.Clear
    
62.     Next k
    
63.    
    
64.     SSetObj.Select acSelectionSetWindow, Pt1, Pt2
    
65.     ssDelete SSetObj, entobj
    
66.     SSetObj.Erase
    
67.    
    
68.    
    
69. ErrTrap:
    
70.     SSetObj.Clear
    
71.     SSetObj.Delete
    
72. End Sub
    
73. 
    

Sub blkTrim()<br /> On Error Resume Next<br />   Dim ent As AcadEntity<br />   Dim sset As AcadSelectionSet<br />   Set sset = CreateSelectionSet("sset")<br />   Dim fType, fData As Variant<br />   BuildFilter fType, fData, 0, "INSERT"<br />   ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下块，若直接回车，则可选择多义线。"<br />   sset.SelectOnScreen fType, fData<br />   If sset.Count = 0 Then<br />     ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下多义线。"<br />     BuildFilter fType, fData, 0, "*Polyline"<br />     sset.SelectOnScreen fType, fData<br />     If sset.Count = 0 Then Exit Sub<br />   End If<br />   <br />   For Each ent In sset<br />     entTrimF ent<br />   Next<br />   <br />   sset.Delete<br />   <br /> End Sub<br /> <br /> <br /> Sub entTrimF(entobj As AcadEntity)<br />     Dim SSetObj As AcadSelectionSet<br />     Dim Pt1 As Variant<br />     Dim Pt2 As Variant<br />     Dim i As Integer<br />     Dim Pt, pnt1 As Variant<br />     Dim bPt(0 To 1) As Double<br />     <br />     <br />     On Error Resume Next<br />     '创建选择集<br />     Set SSetObj = CreateSelectionSet("ss1")<br />     Err.Clear<br />     entobj.GetBoundingBox Pt1, Pt2<br />     <br />   '要截断2次才能保证都截断完成<br />   For k = 0 To 1<br />     SSetObj.Select acSelectionSetCrossing, Pt1, Pt2<br />     '从集合中删除自身实体<br />     ssDelete SSetObj, entobj<br />     If SSetObj.Count = 0 Then GoTo ErrTrap<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 """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr<br />                     Next j<br />                 End If<br />             End If<br />         Next i<br />      SSetObj.Clear<br />     Next k<br />     <br />     SSetObj.Select acSelectionSetWindow, Pt1, Pt2<br />     ssDelete SSetObj, entobj<br />     SSetObj.Erase<br />     <br />     <br /> ErrTrap:<br />     SSetObj.Clear<br />     SSetObj.Delete<br /> End Sub<br /> <br />

引用的函数

2. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
   
3.     Dim fType() As Integer, fData()
   
4.     Dim index As Long, i As Long
   
5.    
   
6.     index = LBound(gCodes) - 1
   
7.         
   
8.     For i = LBound(gCodes) To UBound(gCodes) Step 2
   
9.         index = index + 1
   
10.         ReDim Preserve fType(0 To index)
    
11.         ReDim Preserve fData(0 To index)
    
12.         fType(index) = CInt(gCodes(i))
    
13.         fData(index) = gCodes(i + 1)
    
14.     Next
    
15.     typeArray = fType: dataArray = fData
    
16. End Sub
    
17. Public Sub ssDelete(ss As AcadSelectionSet, ent As AcadEntity)
    
18. 
    
19.     Dim objArray(0 To 0) As AcadEntity
    
20.    
    
21.     Set objArray(0) = ent
    
22.     ss.RemoveItems objArray
    
23. 
    
24. End Sub
    
25. 
    
26. Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
    
27. 
    
28.     Dim ss As AcadSelectionSet
    
29.    
    
30.     On Error Resume Next
    
31.     Set ss = ThisDrawing.SelectionSets(ssName)
    
32.     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
    
33.     ss.Clear
    
34.     Set CreateSelectionSet = ss
    
35. 
    
36. End Function
    
37. 
    
38. 
    

Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())<br />     Dim fType() As Integer, fData()<br />     Dim index As Long, i As Long<br />     <br />     index = LBound(gCodes) - 1<br />         <br />     For i = LBound(gCodes) To UBound(gCodes) Step 2<br />         index = index + 1<br />         ReDim Preserve fType(0 To index)<br />         ReDim Preserve fData(0 To index)<br />         fType(index) = CInt(gCodes(i))<br />         fData(index) = gCodes(i + 1)<br />     Next<br />     typeArray = fType: dataArray = fData<br /> End Sub<br /> Public Sub ssDelete(ss As AcadSelectionSet, ent As AcadEntity)<br /> <br />     Dim objArray(0 To 0) As AcadEntity<br />     <br />     Set objArray(0) = ent<br />     ss.RemoveItems objArray<br /> <br /> End Sub<br /> <br /> Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet<br /> <br />     Dim ss As AcadSelectionSet<br />     <br />     On Error Resume Next<br />     Set ss = ThisDrawing.SelectionSets(ssName)<br />     If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)<br />     ss.Clear<br />     Set CreateSelectionSet = ss<br /> <br /> End Function<br /> <br /> <br />

mikewolf2k

谢谢，先看看．．．．．