[LISP函数]：请高手指点

ybyuan

aeo,你的程序很好用，非常感谢。可惜的是，核心技术我无法搞懂。不知能否指点一二。
eachy改动后的程序好像不能用，不知哪里出了问题。还有，我还是没懂关于排序的问题，用什么命令排序呢？能举例说明吗？谢谢。

aeo

排序:
比如大小排序 li--> '(2 6 1 0 5)
(vl-sort li '(lamba(x y)(< x y))) -->'(0 1 2 5 6)
xdrx_sort-pointoncurve 实际是对点到实体的起点的距离大小排序.

用trim写,好象也要对circle排序的,不然就搞不清要trim那一个(是老的还是新生成的)
或者这么写:每次新老都trim一次,反正已经trim好的再trim是不发生变化的.

eachy

最初由 ybyuan 发布
[B]aeo,你的程序很好用，非常感谢。可惜的是，核心技术我无法搞懂。不知能否指点一二。
eachy改动后的程序好像不能用，不知哪里出了问题。还有，我还是没懂关于排序的问题，用什么命令排序呢？能举例说明吗？谢谢。 [/B]

给你贴几个以前收集的函数参考。

2. 
   
3. ;;升序排列（省略重复项）：;
   
4. ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range1 lst1))
   
5. ;;返回    (-0.4 3.0 5.4)
   
6. (defun range1 (a / b mn mx)
   
7.   (setq        mn (apply 'min a)
   
8.         mn (1- mn)
   
9.   )
   
10.   (while (< mn (setq mx (apply 'max a)))
    
11.     (setq b (cons mx b)
    
12.           a (subst mn mx a)
    
13.     )
    
14.   )
    
15.   b
    
16. )
    
17. ;;升序排列（不省略重复项）：;
    
18. ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range2 lst1))
    
19. ;;返回    (-0.4 3.0 3.0 5.4)
    
20. (defun range2 (a / b c mn mx)
    
21.   (setq        mn (apply 'min a)
    
22.         mn (1- mn)
    
23.   )
    
24.   (while (< mn (setq mx (apply 'max a)))
    
25.     (setq c a
    
26.           a (subst mn mx a)
    
27.     )
    
28.     (while (setq c (member mx c))
    
29.       (setq c (cdr c)
    
30.             b (cons mx b)
    
31.       )
    
32.     )
    
33.   )
    
34.   b
    
35. )
    
36. ;;降序排列（不省略重复项）：;
    
37. ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range3 lst1))
    
38. ;;返回    (5.4 3.0 3.0 -0.4)
    
39. (defun range3 (a / b c mn mx)
    
40.   (setq        mx (apply 'max a)
    
41.         mx (1+ mx)
    
42.   )
    
43.   (while (> mx (setq mn (apply 'min a)))
    
44.     (setq c a
    
45.           a (subst mx mn a)
    
46.     )
    
47.     (while (setq c (member mn c))
    
48.       (setq c (cdr c)
    
49.             b (cons mn b)
    
50.       )
    
51.     )
    
52.   )
    
53.   b
    
54. )

<br /> ;;升序排列（省略重复项）：;<br /> ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range1 lst1))<br /> ;;返回    (-0.4 3.0 5.4)<br /> (defun range1 (a / b mn mx)<br />   (setq        mn (apply 'min a)<br />         mn (1- mn)<br />   )<br />   (while (< mn (setq mx (apply 'max a)))<br />     (setq b (cons mx b)<br />           a (subst mn mx a)<br />     )<br />   )<br />   b<br /> )<br /> ;;升序排列（不省略重复项）：;<br /> ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range2 lst1))<br /> ;;返回    (-0.4 3.0 3.0 5.4)<br /> (defun range2 (a / b c mn mx)<br />   (setq        mn (apply 'min a)<br />         mn (1- mn)<br />   )<br />   (while (< mn (setq mx (apply 'max a)))<br />     (setq c a<br />           a (subst mn mx a)<br />     )<br />     (while (setq c (member mx c))<br />       (setq c (cdr c)<br />             b (cons mx b)<br />       )<br />     )<br />   )<br />   b<br /> )<br /> ;;降序排列（不省略重复项）：;<br /> ;;(setq lst1 '(3 5.4 3 -0.4) lst1 (range3 lst1))<br /> ;;返回    (5.4 3.0 3.0 -0.4)<br /> (defun range3 (a / b c mn mx)<br />   (setq        mx (apply 'max a)<br />         mx (1+ mx)<br />   )<br />   (while (> mx (setq mn (apply 'min a)))<br />     (setq c a<br />           a (subst mx mn a)<br />     )<br />     (while (setq c (member mn c))<br />       (setq c (cdr c)<br />             b (cons mn b)<br />       )<br />     )<br />   )<br />   b<br /> )

另外还有Vla函数

2. 
   
3. 
   
4. [B][color=blur]VL-sort[/color][/B]
   
5. 
   
6. 根据给定的比较函数来对表中的元素排序
   
7. (vl-sort  list comparison-function)
   
8. 
   
9. 参数
   
10. 
    
11. list
    
12. 
    
13. 任意表。
    
14. 
    
15. comparison-function
    
16. 
    
17. 比较函数。它可以是任何一个这样的函数：接受如下两个参数，如果第一个参数按排序顺序在第
    
18. 二个元素之前，则返回 T 或非 nil
    
19. 值。comparison-function 的值可以采用如下格式：
    
20. 
    
21. 符号 (函数名)
    
22.         '(LAMBDA (A1 A2) ...)
    
23.         (FUNCTION (LAMBDA (A1 A2) ...))
    
24. 
    
25. 返回值
    
26. 
    
27. 表，其中包含 list 中的元素，这些元素按照 comparison-function 中指定的顺序排列。表中可能删除了重复的元素。
    
28. 
    
29. 样例
    
30. 
    
31. 对数值表排序：
    
32. 
    
33. _$ (vl-sort '(3 2 1 3) '<)
    
34. 
    
35. (1 2 3)     ;  
    
36. 
    
37. 请注意结果表中仅包含一个 3。
    
38. 按 Y 坐标对二维点表排序：
    
39. 
    
40. _$ (vl-sort '((1 3) (2 2) (3 1))
    
41.              (function (lambda (e1 e2)
    
42.                          (< (cadr e1) (cadr e2)) ) ) )
    
43. 
    
44. ((3 1) (2 2) (1 3))
    
45. 
    
46. 对符号表排序：
    
47. 
    
48. _$ (vl-sort  
    
49.    '(a d c b a)
    
50.    '(lambda (s1 s2)
    
51.      (< (vl-symbol-name s1) (vl-symbol-name s2)) ) )
    
52. 
    
53. (A B C D)       ;  请注意在结果表中仅有一个 A
    
54. 
    
55. [B][color=red]Vl-sort-i[/color][/B]
    
56. 
    
57. 根据给定的比较函数对表中的元素排序，并返回元素的索引号
    
58. (vl-sort-i  list comparison-function)
    
59. 
    
60. 参数
    
61. 
    
62. list
    
63. 
    
64. 任意表。
    
65. 
    
66. comparison-function
    
67. 
    
68. 比较函数。它可以是任何一个这样的函数：接受如下两个参数，如果第一个参数按排序顺序
    
69. 在第二个元素之前，则返回 T 或非 nil
    
70. 值。comparison-function 的值可以采用如下格式：
    
71. 
    
72. 符号 (函数名)
    
73.         '(LAMBDA (A1 A2) ...)
    
74.         (FUNCTION (LAMBDA (A1 A2) ...))
    
75. 
    
76. 返回值
    
77. 
    
78. 表，其中包含 list 中元素的索引值，这些值按照 comparison-function 指定的次序排列。表中保留重复的元素。
    
79. 
    
80. 样例
    
81. 
    
82. 按降序排列字符表：
    
83. 
    
84. _$ (vl-sort-i '("a" "d" "f" "c") '>)
    
85. 
    
86. (2 1 3 0)
    
87. 
    
88. 排序后，表的顺序为 "f" "d" "c"  "a"。"f" 是原始表中的第三个元素（索引号为 2），"d" 是表
    
89. 的第二个元素（索引号为 1）依此类推。
    
90. 按升序排列数值表：
    
91. 
    
92. _$ (vl-sort-i '(3 2 1 3) '<)
    
93. 
    
94. (2 1 3 0)
    
95. 
    
96. 请注意在结果表中包含两个 3 的索引号。
    
97. 按 Y 坐标对二维点表排序：
    
98. 
    
99. _$ (vl-sort-i '((1 3) (2 2) (3 1))
    
100.              (function (lambda (e1 e2)
     
101.                          (< (cadr e1) (cadr e2)) ) ) )
     
102. 
     
103. (2 1 0)
     
104. 
     
105. 对符号表排序：
     
106. 
     
107. _$ (vl-sort-i  
     
108.    '(a d c b a)
     
109.    '(lambda (s1 s2)
     
110.      (< (vl-symbol-name s1) (vl-symbol-name s2)) ) )
     
111. 
     
112. (4 0 3 2 1)
     
113. 
     
114. 请注意结果中包含两个 a 的索引号。

<br /> <br /> [B][color=blur]VL-sort[/color][/B]<br /> <br /> 根据给定的比较函数来对表中的元素排序<br /> (vl-sort  list comparison-function)<br /> <br /> 参数<br /> <br /> list <br /> <br /> 任意表。<br /> <br /> comparison-function <br /> <br /> 比较函数。它可以是任何一个这样的函数：接受如下两个参数，如果第一个参数按排序顺序在第<br /> 二个元素之前，则返回 T 或非 nil <br /> 值。comparison-function 的值可以采用如下格式：<br /> <br /> 符号 (函数名) <br />         '(LAMBDA (A1 A2) ...) <br />         (FUNCTION (LAMBDA (A1 A2) ...)) <br /> <br /> 返回值<br /> <br /> 表，其中包含 list 中的元素，这些元素按照 comparison-function 中指定的顺序排列。表中可能删除了重复的元素。<br /> <br /> 样例<br /> <br /> 对数值表排序：<br /> <br /> _$ (vl-sort '(3 2 1 3) '<) <br /> <br /> (1 2 3)     ;  <br /> <br /> 请注意结果表中仅包含一个 3。<br /> 按 Y 坐标对二维点表排序：<br /> <br /> _$ (vl-sort '((1 3) (2 2) (3 1)) <br />              (function (lambda (e1 e2) <br />                          (< (cadr e1) (cadr e2)) ) ) ) <br /> <br /> ((3 1) (2 2) (1 3))<br /> <br /> 对符号表排序：<br /> <br /> _$ (vl-sort  <br />    '(a d c b a) <br />    '(lambda (s1 s2) <br />      (< (vl-symbol-name s1) (vl-symbol-name s2)) ) ) <br /> <br /> (A B C D)       ;  请注意在结果表中仅有一个 A<br /> <br /> [B][color=red]Vl-sort-i[/color][/B]<br /> <br /> 根据给定的比较函数对表中的元素排序，并返回元素的索引号<br /> (vl-sort-i  list comparison-function)<br /> <br /> 参数<br /> <br /> list <br /> <br /> 任意表。<br /> <br /> comparison-function <br /> <br /> 比较函数。它可以是任何一个这样的函数：接受如下两个参数，如果第一个参数按排序顺序<br /> 在第二个元素之前，则返回 T 或非 nil <br /> 值。comparison-function 的值可以采用如下格式：<br /> <br /> 符号 (函数名) <br />         '(LAMBDA (A1 A2) ...) <br />         (FUNCTION (LAMBDA (A1 A2) ...)) <br /> <br /> 返回值<br /> <br /> 表，其中包含 list 中元素的索引值，这些值按照 comparison-function 指定的次序排列。表中保留重复的元素。<br /> <br /> 样例<br /> <br /> 按降序排列字符表：<br /> <br /> _$ (vl-sort-i '("a" "d" "f" "c") '>) <br /> <br /> (2 1 3 0)<br /> <br /> 排序后，表的顺序为 "f" "d" "c"  "a"。"f" 是原始表中的第三个元素（索引号为 2），"d" 是表<br /> 的第二个元素（索引号为 1）依此类推。<br /> 按升序排列数值表：<br /> <br /> _$ (vl-sort-i '(3 2 1 3) '<) <br /> <br /> (2 1 3 0)<br /> <br /> 请注意在结果表中包含两个 3 的索引号。<br /> 按 Y 坐标对二维点表排序：<br /> <br /> _$ (vl-sort-i '((1 3) (2 2) (3 1)) <br />              (function (lambda (e1 e2) <br />                          (< (cadr e1) (cadr e2)) ) ) ) <br /> <br /> (2 1 0)<br /> <br /> 对符号表排序：<br /> <br /> _$ (vl-sort-i  <br />    '(a d c b a) <br />    '(lambda (s1 s2) <br />      (< (vl-symbol-name s1) (vl-symbol-name s2)) ) ) <br /> <br /> (4 0 3 2 1)<br /> <br /> 请注意结果中包含两个 a 的索引号。

梦断江南

本程序特点：
1。不用排序
2。可跳过交叉以及重合的圆
3。对直线起始点在圆内有效
4。操作过程仅仅需要点击一次（选择直线）
5。纯lisp程序
6。目前仅仅对line有效

使用了以下技巧：
1。ssget "fence"方式选择集自动排序
2。entlast取得需要剪切的实体

2. 
   
3. ;;剪除圆，椭圆中的线段---------完成！！！v1.0 仅限对直线有效
   
4. ;;for xdcad 论坛
   
5. (defun c:xtr (/ ll le ss i e ptc)
   
6. (princ "\nxtr====剪除圆，椭圆中的线段-----------lxx.2003.5")
   
7. (Command ".undo" "be")
   
8. (setq  ll (car (entsel "\n 选择直线:"))
   
9.            le (entget  ll)
   
10.           ss (ssget "f" (list (cdr (assoc 10 le)) (cdr (assoc 11 le)) ) '((0 . "CIRCLE,ELLIPSE")) )
    
11.           i 0)
    
12. (entdel ll)
    
13. (entmake le)  ;方便调整顺序
    
14. (repeat (sslength ss)
    
15.    (setq e (ssname ss i)
    
16.            ptc (cdr (assoc 10 (entget e)))
    
17.            i (1+ i)
    
18.    )
    
19.    (Command "_.trim" e "" (list (entlast) ptc) ^c )
    
20. )
    
21. (Command ".undo" "e")
    
22. (princ)
    
23. )

<br /> ;;剪除圆，椭圆中的线段---------完成！！！v1.0 仅限对直线有效<br /> ;;for xdcad 论坛<br /> (defun c:xtr (/ ll le ss i e ptc)<br /> (princ "\nxtr====剪除圆，椭圆中的线段-----------lxx.2003.5")<br /> (Command ".undo" "be")<br /> (setq  ll (car (entsel "\n 选择直线:"))<br />            le (entget  ll)<br />           ss (ssget "f" (list (cdr (assoc 10 le)) (cdr (assoc 11 le)) ) '((0 . "CIRCLE,ELLIPSE")) )<br />           i 0)<br /> (entdel ll)<br /> (entmake le)  ;方便调整顺序<br /> (repeat (sslength ss)<br />    (setq e (ssname ss i)<br />            ptc (cdr (assoc 10 (entget e)))<br />            i (1+ i)<br />    )<br />    (Command "_.trim" e "" (list (entlast) ptc) ^c )<br /> )<br /> (Command ".undo" "e")<br /> (princ)<br /> )

梦断江南

lisp 程序下载

梦断江南

根据 eachy 前面帖子的思路改的
可以剪切所有线条，不仅仅是直线，可以是pl,spline,circle,arc,ellipse等等。就是速度慢点.  cadr14测试通过
'

2. 
   
3. ;;剪除圆，椭圆中的线段---------完成！！！v1.1 b 版本b   －－－－－－－  对所有线有效
   
4. ;;for xdcad 论坛
   
5. (defun c:xtr (/ ll le ss i e ptc)
   
6. (princ "\nxtr====剪除圆，椭圆中的线段v1.1b 对所有线有效-----------lxx.2003.5")
   
7. (Command ".undo" "be")
   
8. (princ "\n选择剪切边界")
   
9. (setq  ss (ssget  '((0 . "CIRCLE,ELLIPSE")) )
   
10.            ll (car (entsel "\n 选择要剪切的线条:"))
    
11.            lss (cons ll lss)                                                              ;;要剪切的实体组表
    
12.            laste (entlast)
    
13.            i 0)
    
14. (repeat (sslength ss)
    
15.    (setq e (ssname ss i)
    
16.             ptc (cdr (assoc 10 (entget e)))
    
17.             i (1+ i)
    
18.    )
    
19.    (mapcar '( lambda(x)  (Command "_.trim" e "" (list x ptc) ^c )) lss)    ;;对表中每个实体trim
    
20.    (while  (setq nexte (entnext laste))
    
21.                (setq  lss (cons nexte lss)
    
22.                          laste nexte
    
23.                )
    
24.    )
    
25. )
    
26. (Command ".undo" "e")
    
27. (princ)
    
28. )
    

<br /> ;;剪除圆，椭圆中的线段---------完成！！！v1.1 b 版本b   －－－－－－－  对所有线有效<br /> ;;for xdcad 论坛<br /> (defun c:xtr (/ ll le ss i e ptc)<br /> (princ "\nxtr====剪除圆，椭圆中的线段v1.1b 对所有线有效-----------lxx.2003.5")<br /> (Command ".undo" "be")<br /> (princ "\n选择剪切边界")<br /> (setq  ss (ssget  '((0 . "CIRCLE,ELLIPSE")) )<br />            ll (car (entsel "\n 选择要剪切的线条:"))<br />            lss (cons ll lss)                                                              ;;要剪切的实体组表<br />            laste (entlast)<br />            i 0)<br /> (repeat (sslength ss)<br />    (setq e (ssname ss i)<br />             ptc (cdr (assoc 10 (entget e)))<br />             i (1+ i)<br />    )<br />    (mapcar '( lambda(x)  (Command "_.trim" e "" (list x ptc) ^c )) lss)    ;;对表中每个实体trim<br />    (while  (setq nexte (entnext laste))<br />                (setq  lss (cons nexte lss)<br />                          laste nexte<br />                )<br />    )<br /> )<br /> (Command ".undo" "e")<br /> (princ)<br /> )<br />

ybyuan

这里真是个好地方，我想主要是因为有你们这些热心的朋友。谢谢~~~

aeo

19贴
ss (ssget "f" (list (cdr (assoc 10 le)) (cdr (assoc 11 le)) ) '((0 . "CIRCLE,ELLIPSE")) )

其实"f"扫过,已经 排序 好了的.先选直线,再ssget(任意选)圆应该不行.(所以说不要排序,可能你那么理解)

这样就只好交的全trim了

用21贴的吧.好象还可改进,但没必要了,能用就行.(就是新老都trim)

好玩,练练xdapi

2. 
   
3. (defun c:br( / circle j line pt ptn ss)
   
4. (if(and(setq line(car(entsel)))
   
5.         (not(redraw line 3))
   
6.         (setq ss(ssget '((0 . "CIRCLE,ELLIPSE,lwpolyline"))))  )
   
7. (progn(setq ptn '() len(sslength ss) j 0)
   
8.   (while(< j len)(setq circle(ssname ss j))
   
9.    (if(xdrx_getinters line circle )
   
10.     (progn
    
11.     (setq pt(xdrx_getinters line circle 1 ) )
    
12.     (if(>(length pt)1)
    
13.     (setq pt1(car(vl-sort pt'(lambda(a b)
    
14.             (>(xdrx_curve_getDistAtPoint line a)(xdrx_curve_getDistAtPoint line b)))))
    
15.           dis(xdrx_curve_getDistAtPoint line pt1)
    
16.           pc(xdrx_midp (car pt)(cadr pt))
    
17.           ptn(cons(list pc circle dis)ptn) )
    
18.    )))
    
19.     (setq j(1+ j))
    
20.   )
    
21.   (setq ptn(vl-sort ptn'(lambda(a b)(>(last a)(last b)))))
    
22.   (command"undo""group")
    
23.   (mapcar '(lambda(x)(command "trim"(cadr x)"" (list line (car x))"")) ptn)
    
24.   (command"undo""end")
    
25.   ))(princ)
    
26. )

<br /> (defun c:br( / circle j line pt ptn ss)<br /> (if(and(setq line(car(entsel)))<br />         (not(redraw line 3))<br />         (setq ss(ssget '((0 . "CIRCLE,ELLIPSE,lwpolyline"))))  )<br /> (progn(setq ptn '() len(sslength ss) j 0)<br />   (while(< j len)(setq circle(ssname ss j))<br />    (if(xdrx_getinters line circle )<br />     (progn<br />     (setq pt(xdrx_getinters line circle 1 ) )<br />     (if(>(length pt)1)<br />     (setq pt1(car(vl-sort pt'(lambda(a b)<br />             (>(xdrx_curve_getDistAtPoint line a)(xdrx_curve_getDistAtPoint line b)))))<br />           dis(xdrx_curve_getDistAtPoint line pt1)<br />           pc(xdrx_midp (car pt)(cadr pt))<br />           ptn(cons(list pc circle dis)ptn) )<br />    )))<br />     (setq j(1+ j))<br />   ) <br />   (setq ptn(vl-sort ptn'(lambda(a b)(>(last a)(last b)))))<br />   (command"undo""group")<br />   (mapcar '(lambda(x)(command "trim"(cadr x)"" (list line (car x))"")) ptn) <br />   (command"undo""end")<br />   ))(princ)<br /> )

dynasty

高手如云

yelanq

2. [font=courier]
   
3. (defun C:tt (/ cir ln index name cen n)
   
4.   (setvar "cmdecho" 0)
   
5.   (if (progn
   
6.         (prompt "\n select the circle:")
   
7.         (setq cir (ssget '((0 . "circle"))))
   
8.         (setq ln (car (entsel "\nselect line: ")))
   
9.       )
   
10.     (progn
    
11.       (setq index 0
    
12.             n 0
    
13.       )
    
14.       (repeat (sslength cir)
    
15.         (setq name (ssname cir index))
    
16.         (setq index (1+ index))
    
17.         (setq cen (cdr (assoc 10 (entget name))))
    
18.         (command ".trim" name "" (list ln cen) "")
    
19.         (if entlst
    
20.           (setq entlst (list (entlast)))
    
21.           (setq entlst (append (list (entlast)) entlst))
    
22.         )
    
23.       )
    
24.       ;;处理嵌套圆
    
25.       (repeat (sslength cir)
    
26.         (setq name (ssname cir n))
    
27.         (setq n (1+ n))
    
28.         (setq cen (cdr (assoc 10 (entget name))))
    
29.         (foreach e entlst
    
30.           (command ".trim" name "" (list e cen) "")
    
31.         )
    
32.       )
    
33.     )
    
34.   )
    
35.   (princ)
    
36. )
    
37. [/font]
    

[font=courier]<br /> (defun C:tt (/ cir ln index name cen n)<br />   (setvar "cmdecho" 0)<br />   (if (progn<br />         (prompt "\n select the circle:")<br />         (setq cir (ssget '((0 . "circle"))))<br />         (setq ln (car (entsel "\nselect line: ")))<br />       )<br />     (progn<br />       (setq index 0<br />             n 0<br />       )<br />       (repeat (sslength cir)<br />         (setq name (ssname cir index))<br />         (setq index (1+ index))<br />         (setq cen (cdr (assoc 10 (entget name))))<br />         (command ".trim" name "" (list ln cen) "")<br />         (if entlst<br />           (setq entlst (list (entlast)))<br />           (setq entlst (append (list (entlast)) entlst))<br />         )<br />       )<br />       ;;处理嵌套圆<br />       (repeat (sslength cir)<br />         (setq name (ssname cir n))<br />         (setq n (1+ n))<br />         (setq cen (cdr (assoc 10 (entget name))))<br />         (foreach e entlst<br />           (command ".trim" name "" (list e cen) "")<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br /> [/font]<br />

速龙

太厉害了，能不能指点一下怎么用？

LUCAS

[QUOTE]最初由 梦断江南 发布
[B]根据 eachy 前面帖子的思路改的
可以剪切所有线条，不仅仅是直线，可以是pl,spline,circle,arc,ellipse等等。就是速度慢点.  cadr14测试通过
[QUOTE]

2. 
   
3. ;;对"POLYLINE"恐怕不行!
   
4. ;;
   
5. ;;修改LUCAS
   
6. 
   
7. (defun C:XTRR (/ LL LE SS I E PTC LSS NEXTE LASTE)
   
8.   (princ
   
9.     "\nxtr====剪除圆，椭圆中的线段v1.1b 对所有线有效-----------lxx.2003.5"
   
10.   )
    
11.   (command ".undo" "be")
    
12.   (princ "\n选择剪切边界")
    
13.   (setq        SS    (ssget '((0 . "CIRCLE,ELLIPSE")))
    
14.         LL    (car (entsel "\n 选择要剪切的线条:"))
    
15.         TYP   (cdr (assoc 0 (entget LL)))
    
16.         LSS   (cons LL LSS)                ;要剪切的实体组表
    
17.         LASTE (entlast)
    
18.         I     0
    
19.   )
    
20.   (repeat (sslength SS)
    
21.     (setq E   (ssname SS I)
    
22.           PTC (cdr (assoc 10 (entget E)))
    
23.           I   (1+ I)
    
24.     )
    
25.     (mapcar '(lambda (X) (command "_.trim" E "" (list X PTC) ^C))
    
26.             LSS
    
27.     )
    
28. 
    
29.     ;;对表中每个实体trim
    
30.     (if        (not (equal LASTE (entlast)))
    
31.       (progn
    
32.         (if (/= TYP "POLYLINE")
    
33.           (while (setq NEXTE (entnext LASTE))
    
34.             (setq LSS        (cons NEXTE LSS)
    
35.                   LASTE        NEXTE
    
36.             )
    
37.           )
    
38.           (progn
    
39.             (setq NEXTE (entnext LASTE))
    
40.             (while NEXTE
    
41.               (if (and (= (cdr (assoc 0 (entget NEXTE))) "POLYLINE")
    
42.                        (not (member NEXTE LSS))
    
43.                   )
    
44.                 (setq LSS   (cons NEXTE LSS)
    
45.                       LASTE NEXTE
    
46.                 )
    
47.               )
    
48.               (setq NEXTE (entnext NEXTE))
    
49.             )
    
50.           )
    
51.         )
    
52.       )
    
53.     )
    
54. 
    
55.   )
    
56.   (command ".undo" "e")
    
57.   (princ)
    
58. )
    

<br /> ;;对"POLYLINE"恐怕不行!<br /> ;;<br /> ;;修改LUCAS<br /> <br /> (defun C:XTRR (/ LL LE SS I E PTC LSS NEXTE LASTE)<br />   (princ<br />     "\nxtr====剪除圆，椭圆中的线段v1.1b 对所有线有效-----------lxx.2003.5"<br />   )<br />   (command ".undo" "be")<br />   (princ "\n选择剪切边界")<br />   (setq        SS    (ssget '((0 . "CIRCLE,ELLIPSE")))<br />         LL    (car (entsel "\n 选择要剪切的线条:"))<br />         TYP   (cdr (assoc 0 (entget LL)))<br />         LSS   (cons LL LSS)                ;要剪切的实体组表<br />         LASTE (entlast)<br />         I     0<br />   )<br />   (repeat (sslength SS)<br />     (setq E   (ssname SS I)<br />           PTC (cdr (assoc 10 (entget E)))<br />           I   (1+ I)<br />     )<br />     (mapcar '(lambda (X) (command "_.trim" E "" (list X PTC) ^C))<br />             LSS<br />     )<br /> <br />     ;;对表中每个实体trim<br />     (if        (not (equal LASTE (entlast)))<br />       (progn<br />         (if (/= TYP "POLYLINE")<br />           (while (setq NEXTE (entnext LASTE))<br />             (setq LSS        (cons NEXTE LSS)<br />                   LASTE        NEXTE<br />             )<br />           )<br />           (progn<br />             (setq NEXTE (entnext LASTE))<br />             (while NEXTE<br />               (if (and (= (cdr (assoc 0 (entget NEXTE))) "POLYLINE")<br />                        (not (member NEXTE LSS))<br />                   )<br />                 (setq LSS   (cons NEXTE LSS)<br />                       LASTE NEXTE<br />                 )<br />               )<br />               (setq NEXTE (entnext NEXTE))<br />             )<br />           )<br />         )<br />       )<br />     )<br /> <br />   )<br />   (command ".undo" "e")<br />   (princ)<br /> )<br />

weibin

cad命令很好解决，不用编程吧