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

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