求帮助修改一个框选剪切程序

meja

有时候线段两边不齐，一般都是做辅助线剪切点，我的想法是直接画矩形修剪掉，好不容易“拼”好了程序，从左往右剪切没有问题，但从右往左不行，容易留下一个尾巴，求完善！谢谢高手

2. ;========== angle stuff ==============
   
3. ;  Convert angle in degrees to radians
   
4. (defun dtr (a) (* pi (/ a 180.0)))
   
5. 
   
6. ; Convert value in radians to degrees
   
7. (defun RTD (r)   (* 180.0 (/ r pi)))
   
8. ;============================
   
9. ;  MAIN ROUTINE
   
10. ;============================
    
11. (defun C:CLIP ( / sblip scmde
    
12.       @pt1 @pt2 @pt3 @pt4 xpt1 xpt2 fp1 fp2 fp3 fp4
    
13.       en ans anshelp ang sblip scmde en en1
    
14.       ansclip screen ang os cclip inspoint grpcnt)
    
15. ;setup
    
16.   (setq sblip (getvar "blipmode"))
    
17.   (setq scmde (getvar "cmdecho"))
    
18.   (setvar "blipmode" 0)(princ)
    
19.   (setvar "cmdecho" 0)(princ)
    
20.   (command "_.osnap" "off")
    
21.       (if (= grpcnt nil)(setq grpcnt 0) )
    
22. ;get points
    
23.   (prompt "Enter ")
    
24.   (setq @pt1 (getpoint "1st Point :"))
    
25. 
    
26.   (setq @pt2 (getcorner @pt1 "\n2nd Point :"))
    
27. ;Break List of points in x y parts
    
28.   (setq xpt1 (car @pt1) ypt1 (cadr @pt1))
    
29.   (setq xpt2 (car @pt2) ypt2 (cadr @pt2))
    
30. ;Set Trim/Fence Points inside Pline Boundary
    
31.        (if (= xpt1 xpt2)(quit))
    
32. ;=============================================================
    
33. ;;Set PTS if lower left picked first
    
34.        (cond ((and (< xpt1 xpt2)(< ypt1 ypt2))
    
35.          (progn
    
36.     (setq fp1 (list (+ xpt1 0.03125)(+ ypt1 0.03125)))
    
37.     (setq fp2 (list (- xpt2 0.03125)(+ ypt1 0.03125)))
    
38.     (setq fp3 (list (- xpt2 0.03125)(- ypt2 0.03125)))
    
39.     (setq fp4 (list (+ xpt1 0.03125)(- ypt2 0.03125)))
    
40. ;;;;;Set Points to draw PLINE or RECTANGLE Boundary
    
41.     (setq @pt2 (list xpt2 ypt1))
    
42.     (setq @pt3 (list xpt2 ypt2))
    
43.     (setq @pt4 (list xpt1 ypt2))
    
44. ;;;;;Set OFFSET ANGLE
    
45.   (setq ang (dtr (angle @pt1 @pt3) ) )
    
46.    );end progn
    
47.        ));end cond1
    
48. ;=============================================================
    
49. ;;Set PTS if Upper left picked first
    
50.        (cond ((and (< xpt1 xpt2)(> ypt1 ypt2))
    
51.    (progn
    
52.     (setq fp1 (list (+ xpt1 0.03125)(- ypt1 0.03125)))
    
53.     (setq fp2 (list (+ xpt1 0.03125)(+ ypt2 0.03125)))
    
54.     (setq fp3 (list (- xpt2 0.03125)(+ ypt2 0.03125)))
    
55.     (setq fp4 (list (- xpt2 0.03125)(- ypt1 0.03125)))
    
56. ;;;;;Set Points to draw PLINE or RECTANGLE Boundary
    
57.     (setq @pt2 (list xpt2 ypt1))
    
58.     (setq @pt3 (list xpt2 ypt2))
    
59.     (setq @pt4 (list xpt1 ypt2))
    
60. ;;;;;Set OFFSET ANGLE
    
61.     (setq ang (dtr (* -1 (angle @pt1 @pt3) ) ) )
    
62.    );end progn
    
63.        ));end cond2
    
64. ;=============================================================
    
65. ;;Set PTS if Lower Right picked first
    
66.        (cond ((and (> xpt1 xpt2)(< ypt1 ypt2))
    
67.    (progn
    
68.     (setq fp1 (list (- xpt1 0.03125)(+ ypt1 0.03125)))
    
69.     (setq fp2 (list (- xpt1 0.03125)(- ypt2 0.03125)))
    
70.     (setq fp3 (list (+ xpt2 0.03125)(- ypt2 0.03125)))
    
71.     (setq fp4 (list (+ xpt2 0.03125)(+ ypt1 0.03125)))
    
72. ;;;;;Set Points to draw PLINE or RECTANGLE Boundary
    
73.     (setq @pt2 (list xpt2 ypt1))
    
74.     (setq @pt3 (list xpt2 ypt2))
    
75.     (setq @pt4 (list xpt1 ypt2))
    
76. ;;;;;Set OFFSET ANGLE
    
77.   (setq ang (dtr (angle @pt1 @pt3) ) )
    
78.    );end progn
    
79.        ));end cond3
    
80. ;=============================================================
    
81. ;;Set PTS if Upper Right picked first
    
82.        (cond ((and (> xpt1 xpt2)(> ypt1 ypt2))
    
83.    (progn
    
84.     (setq fp1 (list (- xpt1 0.03125)(- ypt1 0.03125)))
    
85.     (setq fp2 (list (- xpt2 0.03125)(- ypt1 0.03125)))
    
86.     (setq fp3 (list (- xpt2 0.03125)(+ ypt2 0.03125)))
    
87.     (setq fp4 (list (- xpt1 0.03125)(+ ypt2 0.03125)))
    
88. ;;;;;Set Points to draw PLINE or RECTANGLE Boundary
    
89.     (setq @pt2 (list xpt2 ypt1))
    
90.     (setq @pt3 (list xpt2 ypt2))
    
91.     (setq @pt4 (list xpt1 ypt2))
    
92. ;;;;;Set OFFSET ANGLE
    
93.   (setq ang (dtr (angle @pt1 @pt3) ) )
    
94.    );end progn
    
95.        ));end cond4
    
96. ;=============================================================
    
97. ;Draw Trim to Boundary
    
98.   (command "_.rectang" @pt1 @pt3)
    
99. ;Get PLINE/REC OUTSIDE Boundary to delete later
    
100.   (setq en (entlast))
     
101.   (command "offset" 1 en (polar '(0.0 0.0) ANG 0.001)"")
     
102. ;Get PLINE/REC INSIDE Boundary to delete later
     
103.   (setq en1 (entlast))
     
104. ;Use TRIM with FENCE to BREAK geometry - repeat 4 times
     
105.    (repeat 4
     
106.   (command "_.trim" "" "F" fp3 fp4 ""
     
107.            "F" fp2 fp3 ""
     
108.            "F" fp1 fp2 ""
     
109.            "F" fp1 fp4 "" "")
     
110.    );end repeat
     
111. (command "_.erase" en1 "")
     
112. (command "_.erase" en "")
     
113. ;==============================================================
     
114. 
     
115. ;==============================================================
     
116. ;Set UCS to WORLD
     
117.   (command "_.ucs" "W")
     
118.   (setvar "blipmode" sblip)(princ)
     
119.   (setvar "cmdecho" scmde)(princ)
     
120. (terpri)
     
121. (terpri)
     
122. (terpri)
     
123.   (PRINC "\nCLIP")(princ)

;========== angle stuff ==============<br /> ;  Convert angle in degrees to radians<br /> (defun dtr (a) (* pi (/ a 180.0)))<br /> <br /> ; Convert value in radians to degrees<br /> (defun RTD (r)   (* 180.0 (/ r pi)))<br /> ;============================<br /> ;  MAIN ROUTINE<br /> ;============================<br /> (defun C:CLIP ( / sblip scmde <br />       @pt1 @pt2 @pt3 @pt4 xpt1 xpt2 fp1 fp2 fp3 fp4<br />       en ans anshelp ang sblip scmde en en1<br />       ansclip screen ang os cclip inspoint grpcnt)<br /> ;setup<br />   (setq sblip (getvar "blipmode"))<br />   (setq scmde (getvar "cmdecho"))<br />   (setvar "blipmode" 0)(princ)<br />   (setvar "cmdecho" 0)(princ)<br />   (command "_.osnap" "off")<br />       (if (= grpcnt nil)(setq grpcnt 0) )<br /> ;get points<br />   (prompt "Enter ")<br />   (setq @pt1 (getpoint "1st Point :"))<br /> <br />   (setq @pt2 (getcorner @pt1 "\n2nd Point :"))<br /> ;Break List of points in x y parts<br />   (setq xpt1 (car @pt1) ypt1 (cadr @pt1))<br />   (setq xpt2 (car @pt2) ypt2 (cadr @pt2))<br /> ;Set Trim/Fence Points inside Pline Boundary<br />        (if (= xpt1 xpt2)(quit))<br /> ;=============================================================<br /> ;;Set PTS if lower left picked first<br />        (cond ((and (< xpt1 xpt2)(< ypt1 ypt2))<br />          (progn<br />     (setq fp1 (list (+ xpt1 0.03125)(+ ypt1 0.03125)))<br />     (setq fp2 (list (- xpt2 0.03125)(+ ypt1 0.03125)))<br />     (setq fp3 (list (- xpt2 0.03125)(- ypt2 0.03125)))<br />     (setq fp4 (list (+ xpt1 0.03125)(- ypt2 0.03125)))<br /> ;;;;;Set Points to draw PLINE or RECTANGLE Boundary<br />     (setq @pt2 (list xpt2 ypt1))<br />     (setq @pt3 (list xpt2 ypt2))<br />     (setq @pt4 (list xpt1 ypt2))<br /> ;;;;;Set OFFSET ANGLE<br />   (setq ang (dtr (angle @pt1 @pt3) ) )<br />    );end progn<br />        ));end cond1<br /> ;=============================================================<br /> ;;Set PTS if Upper left picked first<br />        (cond ((and (< xpt1 xpt2)(> ypt1 ypt2))<br />    (progn<br />     (setq fp1 (list (+ xpt1 0.03125)(- ypt1 0.03125)))<br />     (setq fp2 (list (+ xpt1 0.03125)(+ ypt2 0.03125)))<br />     (setq fp3 (list (- xpt2 0.03125)(+ ypt2 0.03125)))<br />     (setq fp4 (list (- xpt2 0.03125)(- ypt1 0.03125)))<br /> ;;;;;Set Points to draw PLINE or RECTANGLE Boundary<br />     (setq @pt2 (list xpt2 ypt1))<br />     (setq @pt3 (list xpt2 ypt2))<br />     (setq @pt4 (list xpt1 ypt2))<br /> ;;;;;Set OFFSET ANGLE<br />     (setq ang (dtr (* -1 (angle @pt1 @pt3) ) ) )<br />    );end progn<br />        ));end cond2<br /> ;=============================================================<br /> ;;Set PTS if Lower Right picked first<br />        (cond ((and (> xpt1 xpt2)(< ypt1 ypt2))<br />    (progn<br />     (setq fp1 (list (- xpt1 0.03125)(+ ypt1 0.03125)))<br />     (setq fp2 (list (- xpt1 0.03125)(- ypt2 0.03125)))<br />     (setq fp3 (list (+ xpt2 0.03125)(- ypt2 0.03125)))<br />     (setq fp4 (list (+ xpt2 0.03125)(+ ypt1 0.03125)))<br /> ;;;;;Set Points to draw PLINE or RECTANGLE Boundary<br />     (setq @pt2 (list xpt2 ypt1))<br />     (setq @pt3 (list xpt2 ypt2))<br />     (setq @pt4 (list xpt1 ypt2))<br /> ;;;;;Set OFFSET ANGLE<br />   (setq ang (dtr (angle @pt1 @pt3) ) )<br />    );end progn<br />        ));end cond3<br /> ;=============================================================<br /> ;;Set PTS if Upper Right picked first<br />        (cond ((and (> xpt1 xpt2)(> ypt1 ypt2))<br />    (progn<br />     (setq fp1 (list (- xpt1 0.03125)(- ypt1 0.03125)))<br />     (setq fp2 (list (- xpt2 0.03125)(- ypt1 0.03125)))<br />     (setq fp3 (list (- xpt2 0.03125)(+ ypt2 0.03125)))<br />     (setq fp4 (list (- xpt1 0.03125)(+ ypt2 0.03125)))<br /> ;;;;;Set Points to draw PLINE or RECTANGLE Boundary<br />     (setq @pt2 (list xpt2 ypt1))<br />     (setq @pt3 (list xpt2 ypt2))<br />     (setq @pt4 (list xpt1 ypt2))<br /> ;;;;;Set OFFSET ANGLE<br />   (setq ang (dtr (angle @pt1 @pt3) ) )<br />    );end progn<br />        ));end cond4<br /> ;=============================================================<br /> ;Draw Trim to Boundary<br />   (command "_.rectang" @pt1 @pt3)<br /> ;Get PLINE/REC OUTSIDE Boundary to delete later<br />   (setq en (entlast))<br />   (command "offset" 1 en (polar '(0.0 0.0) ANG 0.001)"")<br /> ;Get PLINE/REC INSIDE Boundary to delete later<br />   (setq en1 (entlast))<br /> ;Use TRIM with FENCE to BREAK geometry - repeat 4 times<br />    (repeat 4<br />   (command "_.trim" "" "F" fp3 fp4 ""<br />            "F" fp2 fp3 ""<br />            "F" fp1 fp2 ""<br />            "F" fp1 fp4 "" "")<br />    );end repeat<br /> (command "_.erase" en1 "")<br /> (command "_.erase" en "")<br /> ;==============================================================<br /> <br /> ;==============================================================<br /> ;Set UCS to WORLD<br />   (command "_.ucs" "W")<br />   (setvar "blipmode" sblip)(princ)<br />   (setvar "cmdecho" scmde)(princ)<br /> (terpri)<br /> (terpri)<br /> (terpri)<br />   (PRINC "\nCLIP")(princ)