选择多义线或块引用则把通过框内线打断的程序
在efan那个打断线交点的程序上改的。只对于方形块引用和多义线有效。而且速度比较慢。
对于通过块应用的多义线，也无效。
以上不知道如何解决。望高手指点。
主程序
Sub blkTrim()
On Error Resume Next
Dim ent As AcadEntity
Dim sset As AcadSelectionSet
Set sset = CreateSelectionSet("sset")
Dim fType, fData As Variant
BuildFilter fType, fData, 0, "INSERT"
ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下块，若直接回车，则可选择多义线。"
sset.SelectOnScreen fType, fData
If sset.Count = 0 Then
ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下多义线。"
BuildFilter fType, fData, 0, "*Polyline"
sset.SelectOnScreen fType, fData
If sset.Count = 0 Then Exit Sub
End If
For Each ent In sset
entTrimF ent
Next
sset.Delete
End Sub
Sub entTrimF(entobj As AcadEntity)
Dim SSetObj As AcadSelectionSet
Dim Pt1 As Variant
Dim Pt2 As Variant
Dim i As Integer
Dim Pt, pnt1 As Variant
Dim bPt(0 To 1) As Double
On Error Resume Next
'创建选择集
Set SSetObj = CreateSelectionSet("ss1")
Err.Clear
entobj.GetBoundingBox Pt1, Pt2
'要截断2次才能保证都截断完成
For k = 0 To 1
SSetObj.Select acSelectionSetCrossing, Pt1, Pt2
'从集合中删除自身实体
ssDelete SSetObj, entobj
If SSetObj.Count = 0 Then GoTo ErrTrap
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 """ & SSetObj(i).Handle & """)" & vbCr & bPt(0) & "," & bPt(1) & vbCr & "@" & vbCr
Next j
End If
End If
Next i
SSetObj.Clear
Next k
SSetObj.Select acSelectionSetWindow, Pt1, Pt2
ssDelete SSetObj, entobj
SSetObj.Erase
ErrTrap:
SSetObj.Clear
SSetObj.Delete
End Sub
引用的函数
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
Dim fType() As Integer, fData()
Dim index As Long, i As Long
index = LBound(gCodes) - 1
For i = LBound(gCodes) To UBound(gCodes) Step 2
index = index + 1
ReDim Preserve fType(0 To index)
ReDim Preserve fData(0 To index)
fType(index) = CInt(gCodes(i))
fData(index) = gCodes(i + 1)
Next
typeArray = fType: dataArray = fData
End Sub
Public Sub ssDelete(ss As AcadSelectionSet, ent As AcadEntity)
Dim objArray(0 To 0) As AcadEntity
Set objArray(0) = ent
ss.RemoveItems objArray
End Sub
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss
End Function
谢谢，先看看．．．．．
页:
[1]