关于trim功能的运用

Sub blkTrim()
 On Error Resume Next
  Dim ent As AcadEntity
  Dim sset As AcadSelectionSet
  Set sset = CreateSelectionSet("sset")
  Dim fType, fData As Variant
  Dim lwplineobj As AcadLWPolyline
  Dim pt1, pt2 As Variant
  Dim points(0 To 9) As Double
  Dim isblock As Boolean
  BuildFilter fType, fData, 0, "INSERT"
  ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下块，若直接回车，则可选择多段线。"
  sset.SelectOnScreen fType, fData
  
  If sset.Count = 0 Then
    ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下多段线。"
    BuildFilter fType, fData, 0, "lwPolyline"
    sset.SelectOnScreen fType, fData
    If sset.Count = 0 Then Exit Sub
    
    For Each ent In sset
      entTrimF ent
    Next
  Else
    For Each ent In sset
      ent.GetBoundingBox pt1, pt2
      points(0) = pt1(0): points(1) = pt1(1)
      points(2) = pt1(0): points(3) = pt2(1)
      points(4) = pt2(0): points(5) = pt2(1)
      points(6) = pt2(0): points(7) = pt1(1)
      points(8) = pt1(0): points(9) = pt1(1)
      Set lwplineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
      entTrimF lwplineobj
      lwplineobj.Delete
    Next
  End If
  sset.Delete
End Sub
'此过程把和多段线plineobj相交的线都剪切
Sub entTrimF(plineObj As AcadEntity)
    Dim offplineObj As Variant
    Dim copyplineobj As AcadEntity
    Dim Coors As Variant
    Dim coorString, cmdString As String
    Dim i As Integer
    Dim offdist As Double
    Set copyplineobj = plineObj.Copy
    
    If IsClockWise(copyplineobj) Then offdist = 0.01 Else: offdist = -0.01
    
    offplineObj = copyplineobj.Offset(offdist)
    offplineObj(0).Update
    
    Coors = offplineObj(0).Coordinates
    offplineObj(0).Delete
    copyplineobj.Delete
    
    coorString = ""
    For i = LBound(Coors) To UBound(Coors) Step 2
      coorString = coorString & Coors(i) & "," & Coors(i + 1) & ",0" & vbCr
    Next i
    cmdString = "trim" & vbCr & "(handent """ & plineObj.Handle & """)" & vbCr & vbCr & _
                "f" & vbCr & coorString & vbCr & vbCr
    
    ThisDrawing.SendCommand cmdString
    ThisDrawing.SendCommand cmdString
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
Public Function IsClockWise(objEntity As AcadEntity) As Boolean
    On Error Resume Next
    Dim NewObj As Variant
    Dim oldobj As AcadEntity
    Set oldobj = objEntity.Copy
    NewObj = oldobj.Offset(-0.01)
    Dim Area1 As Double
    Dim Area2 As Double
    Area1 = objEntity.Area
    Area2 = NewObj(0).Area
    Dim i As Integer
    For i = 0 To UBound(NewObj)
        NewObj(i).Delete
    Next
    oldobj.Delete
    If Area1 < Area2 Then IsClockWise = True
End Function