我也做了一个和你一样的程序,编程的思路也一样,不过我是用vba做的,已经调试成功,没有可以直接使用了。
你说的那个多段线多次穿过的问题我也遇到了,还没有解决,在程序里我用了2次截断,对于穿过边界的一般的多段线是够用了。
下面是我的程序代码,如果方便可以和楼主交流一下,看看怎么才能做的更好。
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