菜鸟新手刚写的统计矩形边长和数量的LISP,求高手完善

scream2658

    买了猫老师的视频教程，看了一个星期的初级视频，也学着写了个LISP。当中也参考了论坛上几位高手的LISP程序。
现在奉献源码供大家参考。也帮忙完善下。 目前这个LISP还 有几个BUG，在处理非水平的矩形时，虽然边长相等，但是还是会误认为是单个的矩形。
运行的时候，命令行也提示有错误。在下真的是能力有限，没办法修改了。望各位高手指点下。

清水白粥

ZZXXQQ 发表于 2013-7-5 22:37

大哥，你这是什么字体呀，cad出来的是乱码的

kzd2004

要是能导入excel就好了。

THZL

支持分享，谢谢!

flytoday

建议弄出三角形……圆形…平行四边形……扇形……等

tianyi1230

一个星期就如此了，不错了，感谢共享

ZZXXQQ

2. ;;;统计相同矩形边长的数量.
   
3. ;;;编写日期2013-07-05
   
4. ;;;编写: CADMAN
   
5. ;;子函数 （求矩形边长）   
   
6. (defun qbc (pts / b h)
   
7. (setq b (distance (car pts) (cadddr pts)))
   
8. (setq h (distance (car pts) (cadr pts)))
   
9. (cons (max b h) (min b h))
   
10. );结束qbc
    
11. (defun c:tg ( / bclst pts ss el bc_new i p2 p3 m x1 x2)
    
12. (princ "\n请框选矩形:")
    
13. (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4))))
    
14. (setq i 0 bclst nil pts nil)
    
15. (repeat (sslength ss)
    
16.   (setq el (entget (ssname ss i)))
    
17.   (setq pts nil)
    
18.   (foreach pt el (if (= (car pt) 10) (setq pts (cons (cdr pt) pts))))      
    
19.   (setq bclst (cons (qbc pts) bclst))
    
20.   (setq i (1+ i))
    
21. );repeat
    
22. (setq bc_new nil)
    
23. (while bclst
    
24.   (setq m (car bclst) x1 (length bclst))
    
25.   (setq bclst (vl-remove m bclst))
    
26.   (setq x2 (length bclst))
    
27.   (setq n (- x1 x2))
    
28.   (setq bc_new (cons (list m n) bc_new))
    
29. )
    
30. (setq p2 (getpoint "\起始位置"))
    
31. (setq p3 (polar p2 0 3000))
    
32. (command "_.TEXT" "c" (polar p2 (* pi 0.5) 800) "500" "0" "矩形边长");指定书写标题的位置
    
33. (command "_.TEXT" "c" (polar p3 (* pi 0.5) 800) "500" "0" "数量")
    
34. (foreach bg bc_new                                                      ;设定重复次数为新表的长度
    
35.   (command "_.TEXT" "c" p2 "400" "0" (strcat (rtos (car (car bg)) 2)"x" (rtos (cdr (car bg))2)))      
    
36.   (command "_.TEXT" "c" p3 "400" "0" (cadr bg))
    
37.   (setq p2 (polar p2 (* pi 1.5) 800))
    
38.   (setq p3 (polar p2 0 3000))
    
39. )
    
40. (princ)
    
41. )

;;;统计相同矩形边长的数量.<br /> ;;;编写日期2013-07-05<br /> ;;;编写: CADMAN<br /> ;;子函数 （求矩形边长）    <br /> (defun qbc (pts / b h)<br /> (setq b (distance (car pts) (cadddr pts)))<br /> (setq h (distance (car pts) (cadr pts)))<br /> (cons (max b h) (min b h))<br /> );结束qbc<br /> (defun c:tg ( / bclst pts ss el bc_new i p2 p3 m x1 x2)<br /> (princ "\n请框选矩形:")<br /> (setq ss (ssget '((0 . "LWPOLYLINE") (90 . 4))))<br /> (setq i 0 bclst nil pts nil)<br /> (repeat (sslength ss)<br />   (setq el (entget (ssname ss i)))<br />   (setq pts nil)<br />   (foreach pt el (if (= (car pt) 10) (setq pts (cons (cdr pt) pts))))       <br />   (setq bclst (cons (qbc pts) bclst))<br />   (setq i (1+ i))<br /> );repeat<br /> (setq bc_new nil)<br /> (while bclst<br />   (setq m (car bclst) x1 (length bclst))<br />   (setq bclst (vl-remove m bclst))<br />   (setq x2 (length bclst))<br />   (setq n (- x1 x2))<br />   (setq bc_new (cons (list m n) bc_new))<br /> )<br /> (setq p2 (getpoint "\起始位置"))<br /> (setq p3 (polar p2 0 3000))<br /> (command "_.TEXT" "c" (polar p2 (* pi 0.5) 800) "500" "0" "矩形边长");指定书写标题的位置<br /> (command "_.TEXT" "c" (polar p3 (* pi 0.5) 800) "500" "0" "数量")<br /> (foreach bg bc_new                                                      ;设定重复次数为新表的长度<br />   (command "_.TEXT" "c" p2 "400" "0" (strcat (rtos (car (car bg)) 2)"x" (rtos (cdr (car bg))2)))       <br />   (command "_.TEXT" "c" p3 "400" "0" (cadr bg))<br />   (setq p2 (polar p2 (* pi 1.5) 800))<br />   (setq p3 (polar p2 0 3000))<br /> )<br /> (princ)<br /> )

scream2658

ZZXXQQ 发表于 2013-7-5 22:37

版主好心人哪。你这样一优化，确实流畅了不少。谢谢！非常感谢！

云中孤鹰

支持一一下！

陈亚娣

支持一下

yaya-54

好东西，试用下。谢谢

yaya-54

ZZXXQQ：WIN7.64位，autocad2010加载程序后提示语法错误。

edata

yaya-54 发表于 2013-12-27 10:27
ZZXXQQ：WIN7.64位，autocad2010加载程序后提示语法错误。

第十三行
(setq i 0 bclst nil pts nil)