[LISP函数]：加中心线自动识别同心圆程序。

fsxm

这个很古老的问题了哦！
发一个我写的让各位老大看看
有什么不足还请多多指教：

fsxm

免的下载直接发算了！！

2. 
   
3. (princ "\n加中心线自动识别同心圆,调用命令：zxx (作者：飞诗寻梦;fsxm)")
   
4. (defun c:zxx (/ r+ la k na lst cen r lst2 r&cen p1 p2 p3 p4)
   
5.   (while (not (setq ss (ssget '((0 . "*rc*"))))))
   
6.   (setq r+ (getdist "\n   请输入中心线超出圆长<5>："))
   
7.   (if (null r+) (setq r+ 5))
   
8.   (setq la (assoc 8 (entget (car (entsel "\n   选取中心线层的一个对像：")))))  
   
9.   (setq k 0)
   
10.   (repeat (sslength ss)
    
11.     (setq na (ssname ss k))
    
12.     (setq k (1+ k))
    
13.     (setq lst (entget na))
    
14.     (setq cen (assoc 10 lst))
    
15.     (setq r (cdr (assoc 40 lst)))
    
16.     (setq lst2 (cons (list r cen) lst2))
    
17.   )
    
18.   (setq lst2 (vl-sort lst2 '(lambda (a b) (> (car a) (car b)))))
    
19.   (command ".undo" "BE")
    
20.   (while (setq r&cen (car lst2))
    
21.     (setq p1 (mapcar '+ (cadr r&cen) (list 0 (+ (car r&cen) r+) 0 0)))
    
22.     (setq p2 (mapcar '- (cadr r&cen) (list -1 (+ (car r&cen) r+) 0 0)))
    
23.     (setq p3 (mapcar '+ (cadr r&cen) (list 0 0 (+ (car r&cen) r+) 0)))
    
24.     (setq p4 (mapcar '- (cadr r&cen) (list -1 0 (+ (car r&cen) r+) 0)))
    
25.     (setq
    
26.       lst2 (vl-remove-if
    
27.              '(lambda (a)
    
28.                 (EQUAL (cadr a) (cadr r&cen))
    
29.               )
    
30.              (cdr lst2)
    
31.            )
    
32.     )
    
33.     (entmakex (list '(0 . "line") la p1 p2))
    
34.     (entmakex (list '(0 . "line") la p3 p4))
    
35.   )  
    
36.   (command ".undo" "E")
    
37.   (princ)
    
38. )

<br /> (princ "\n加中心线自动识别同心圆,调用命令：zxx (作者：飞诗寻梦;fsxm)")<br /> (defun c:zxx (/ r+ la k na lst cen r lst2 r&cen p1 p2 p3 p4)<br />   (while (not (setq ss (ssget '((0 . "*rc*"))))))<br />   (setq r+ (getdist "\n   请输入中心线超出圆长<5>："))<br />   (if (null r+) (setq r+ 5))<br />   (setq la (assoc 8 (entget (car (entsel "\n   选取中心线层的一个对像：")))))  <br />   (setq k 0)<br />   (repeat (sslength ss)<br />     (setq na (ssname ss k))<br />     (setq k (1+ k))<br />     (setq lst (entget na))<br />     (setq cen (assoc 10 lst))<br />     (setq r (cdr (assoc 40 lst)))<br />     (setq lst2 (cons (list r cen) lst2))<br />   )<br />   (setq lst2 (vl-sort lst2 '(lambda (a b) (> (car a) (car b)))))<br />   (command ".undo" "BE")<br />   (while (setq r&cen (car lst2))<br />     (setq p1 (mapcar '+ (cadr r&cen) (list 0 (+ (car r&cen) r+) 0 0)))<br />     (setq p2 (mapcar '- (cadr r&cen) (list -1 (+ (car r&cen) r+) 0 0)))<br />     (setq p3 (mapcar '+ (cadr r&cen) (list 0 0 (+ (car r&cen) r+) 0)))<br />     (setq p4 (mapcar '- (cadr r&cen) (list -1 0 (+ (car r&cen) r+) 0)))<br />     (setq<br />       lst2 (vl-remove-if<br />              '(lambda (a)<br />                 (EQUAL (cadr a) (cadr r&cen))<br />               )<br />              (cdr lst2)<br />            )<br />     )<br />     (entmakex (list '(0 . "line") la p1 p2))<br />     (entmakex (list '(0 . "line") la p3 p4))<br />   )  <br />   (command ".undo" "E")<br />   (princ)<br /> )

eachy

vl-remove-if 放在 while 内部浪费时间

fsxm

多谢老板的支持和建议！！！！！！！
我一定加油努力！