关于trim功能的运用

mikewolf2k

根据看到的帖子,我做了一个vb实现trim功能的程序.基本思路如下:
先做出一个封闭的矩形polyline,然后用sendcommand命令,边界选用此矩形,然后用"F"命令,输入比矩形polyline四个顶点稍靠内的四个点坐标,这样矩形polyline范围内所有能剪切的实体都被截断.
这样做如果是在cad命令行中操作,一切正常.但通过vb程序操作时,cad会出现一个对话框"Can't run macro,AutoCAD is busy",点击确定后对话框消失,程序结束.然后再在命令行中输入一个回车,命令行的trim命令结束.此时polyline内的实体被截断,达到预定目标.
请问这个对话框是怎么回事,怎样避免?它对我的程序无用,除去就大吉了.

mikewolf2k

另外,刚刚调试时发现,如果一个实体,比如多义线,来回几次穿过剪切边界时,用"F"一次只能截断一次穿过剪切边界的部分,再"F"一次又截断一部分,就跟用点选取一样.由于不能事先知道有几次穿过,也就是说不能确定要"F"几次.各位有什么办法解决吗?
注:在命令行执行trim命令,情况一样.

subtlation

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

2. 
   
3. Sub blkTrim()
   
4. 
   
5. On Error Resume Next
   
6.   Dim ent As AcadEntity
   
7.   Dim sset As AcadSelectionSet
   
8.   Set sset = CreateSelectionSet("sset")
   
9.   Dim fType, fData As Variant
   
10.   Dim lwplineobj As AcadLWPolyline
    
11.   Dim pt1, pt2 As Variant
    
12.   Dim points(0 To 9) As Double
    
13.   Dim isblock As Boolean
    
14.   BuildFilter fType, fData, 0, "INSERT"
    
15.   ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下块，若直接回车，则可选择多段线。"
    
16.   sset.SelectOnScreen fType, fData
    
17.   
    
18.   If sset.Count = 0 Then
    
19.     ThisDrawing.Utility.Prompt "选择对象，会过滤其它对象，只留下多段线。"
    
20.     BuildFilter fType, fData, 0, "lwPolyline"
    
21.     sset.SelectOnScreen fType, fData
    
22.     If sset.Count = 0 Then Exit Sub
    
23.    
    
24.     For Each ent In sset
    
25.       entTrimF ent
    
26.     Next
    
27.   Else
    
28.     For Each ent In sset
    
29.       ent.GetBoundingBox pt1, pt2
    
30.       points(0) = pt1(0): points(1) = pt1(1)
    
31.       points(2) = pt1(0): points(3) = pt2(1)
    
32.       points(4) = pt2(0): points(5) = pt2(1)
    
33.       points(6) = pt2(0): points(7) = pt1(1)
    
34.       points(8) = pt1(0): points(9) = pt1(1)
    
35.       Set lwplineobj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
    
36.       entTrimF lwplineobj
    
37.       lwplineobj.Delete
    
38.     Next
    
39.   End If
    
40.   sset.Delete
    
41. End Sub
    
42. 
    
43. '此过程把和多段线plineobj相交的线都剪切
    
44. Sub entTrimF(plineObj As AcadEntity)
    
45.     Dim offplineObj As Variant
    
46.     Dim copyplineobj As AcadEntity
    
47.     Dim Coors As Variant
    
48.     Dim coorString, cmdString As String
    
49.     Dim i As Integer
    
50.     Dim offdist As Double
    
51.     Set copyplineobj = plineObj.Copy
    
52.    
    
53.     If IsClockWise(copyplineobj) Then offdist = 0.01 Else: offdist = -0.01
    
54.    
    
55.     offplineObj = copyplineobj.Offset(offdist)
    
56.     offplineObj(0).Update
    
57.    
    
58.     Coors = offplineObj(0).Coordinates
    
59.     offplineObj(0).Delete
    
60.     copyplineobj.Delete
    
61.    
    
62.     coorString = ""
    
63.     For i = LBound(Coors) To UBound(Coors) Step 2
    
64.       coorString = coorString & Coors(i) & "," & Coors(i + 1) & ",0" & vbCr
    
65.     Next i
    
66.     cmdString = "trim" & vbCr & "(handent """ & plineObj.Handle & """)" & vbCr & vbCr & _
    
67.                 "f" & vbCr & coorString & vbCr & vbCr
    
68.    
    
69.     ThisDrawing.SendCommand cmdString
    
70.     ThisDrawing.SendCommand cmdString
    
71. 
    
72. End Sub
    

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

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 /> Public Function IsClockWise(objEntity As AcadEntity) As Boolean<br />     On Error Resume Next<br />     Dim NewObj As Variant<br />     Dim oldobj As AcadEntity<br />     Set oldobj = objEntity.Copy<br />     NewObj = oldobj.Offset(-0.01)<br />     Dim Area1 As Double<br />     Dim Area2 As Double<br />     Area1 = objEntity.Area<br />     Area2 = NewObj(0).Area<br />     Dim i As Integer<br />     For i = 0 To UBound(NewObj)<br />         NewObj(i).Delete<br />     Next<br />     oldobj.Delete<br />     If Area1 < Area2 Then IsClockWise = True<br /> End Function<br />

mikewolf2k

3楼,我想你可能还没有对你的程序进行多种情况下的测试.比如弧线,各种线宽的多义线(线宽小于剪切范围,线宽大于剪切范围,线宽一部分在剪切范围内等)等等.另外我发现,用"F"时偏移量的多少(0.001和0.1)剪切的结果有时候也不一样.你试试你的看.
另外给个建议,你现在是用"F"时选择了一圈,这样对于反复穿越的线只算一次,而改为"F"时一次只输入一段,多"F"几次,这样同样是选择一圈,"F"的次数却不同.还有你选择时没有回到第一点,是个未封闭区域,应该再把第一点加在最后.
对于需要多次剪切的问题,我也没办法.多次剪切总归不是治本之道.
关于此程序,有什么新的思路,欢迎与我交流.

subtlation

4楼说得对，我的多义线几乎都不用宽度的。所以有线宽的多义线都没有测试过。这个程序主要是让自己绘图时能快一些。所以一些自己不会遇到的情况都没有测试。封闭的弧形我试过是可以的。
偏移量的多少好像没有关系，一般的图几乎没有会用到0.01以下的数值。所以只要偏移的精度达到0.01就应该没有问题了。