[LISP程序]：申请一个LISP程序

haojia

麻烦各位大师帮帮忙，面积的命令AREA只能一次性算一个封闭线段的面积，他只能点击选择。如果要算多个面积的话，可以在AREA命令输入后输入一个只命令S（subtract），然后再按只命令O（object）或则E。他就可以一次性算多个封闭的面积，而且可以自动计算面积的叠加，但是还是得点击选择，很麻烦，得一个一个面积快的点。能不能编辑一个程序可以让AREA命令的计算多个面积的时候有框选的命令?按了命令，然后对着多个小块块一框搞定，他还能自动计算出几个小块块总共的面积，我想这样会方便很多人的。虽然可能这个命令的利用率不是很大，但是还是很方便的。如果这个命令没有出现过的话，是个好意见哦。大家摆脱了！！为cad的将来都来贡献力量吧！！

taner

不知我的理解对否?

2. 
   
3. (defun c:asas (/ a b c i ar z)
   
4.   (setq z (getvar "cmdecho"))
   
5.   (setvar "cmdecho" 0)
   
6.   (setq a (ssget))
   
7.   (setq b (sslength a))
   
8.   (setq        c 0
   
9.         i 0
   
10.   )
    
11. 
    
12.   (while (< i b)
    
13.     (command "area" "o" (ssname a i))
    
14.     (setq ar (getvar "area"))
    
15.     (setq c (+ c ar))
    
16.     (prompt (strcat "\n 第"
    
17.                     (RTOS (1+ I))
    
18.                     "个实体的面积为:"
    
19.                     (rtos ar)
    
20.             )
    
21.     )
    
22. 
    
23.     (setq i (1+ i))
    
24.   )
    
25.   (setvar "cmdecho" z)
    
26.   (prompt (strcat "\n 总面积为:"
    
27.                   (rtos c)
    
28.           )
    
29.   )
    
30.   (princ)
    
31. )

<br /> (defun c:asas (/ a b c i ar z)<br />   (setq z (getvar "cmdecho"))<br />   (setvar "cmdecho" 0)<br />   (setq a (ssget))<br />   (setq b (sslength a))<br />   (setq        c 0<br />         i 0<br />   )<br /> <br />   (while (< i b)<br />     (command "area" "o" (ssname a i))<br />     (setq ar (getvar "area"))<br />     (setq c (+ c ar))<br />     (prompt (strcat "\n 第"<br />                     (RTOS (1+ I))<br />                     "个实体的面积为:"<br />                     (rtos ar)<br />             )<br />     )<br /> <br />     (setq i (1+ i))<br />   )<br />   (setvar "cmdecho" z)<br />   (prompt (strcat "\n 总面积为:"<br />                   (rtos c)<br />           )<br />   )<br />   (princ)<br /> )

haojia

我真是孤陋寡闻了！还以为有点难度，谁知道……以后一定要好好努力，专门想一些对大家有点难度的问题才行！

陌生人

算面积的程序在论坛已经很多了：）你这个题目倒是可以作为lisp编程入门的练习。
另外，二楼程序没有用过滤会有些问题。比如line，text执行
(command "area" "o" (ssname a i))命令就不会自动结束。要么设置过滤，要么强行中断(command "area" "o" (ssname a i)  ^c)但还要做个命名是否正确执行的判断，要不得到的area是上一个成功执行的结果。因此，最好是加过滤：）

haojia

我是做建筑设计的，并不是做施工图，所以需要简单的命令，只要计算面积总和就够了，之前写的命令考虑的太多太复杂了，所以我需要一个针对性比较弱的简单的命令，这个就很适合我，至于您说的过滤什么的的确为大局着想是好，但是在这里，我不是很需要哦。呵呵所以我还是非常感谢楼上的啦

neo

2. (defun c:warea()
   
3. (setvar "cmdecho" 0)
   
4. (SETQ SS1 (SSGET))
   
5. (setq n (SSlength ss1))
   
6. (setq m 0)
   
7. (setq nm 0)
   
8. (SETQ nm0 0)
   
9. (while (< m n )
   
10.        (setq s1 (ssname ss1 m))
    
11.        (SETQ SSL (ENTGET  S1))
    
12.        (IF (/= (CDR (ASSOC 0 SSL)) "LWPOLYLINE")
    
13.           (progn
    
14.           (command "change" s1 "" "p" "la" "0" "")
    
15.           (setq nm0 (+ 1 nm0))
    
16.           )
    
17.        )
    
18.        (if (= (cdr (assoc 70  SSL)) 0)
    
19.           (progn
    
20.           (command "change" s1 "" "p" "la" "0" "")
    
21.           (setq nm (+ 1 nm))
    
22.           )
    
23.       )
    
24.      (setq m (+ 1 m))
    
25.   )
    
26. 
    
27. (if (or (/= nm 0) (/= nm0 0))
    
28.       (progn
    
29.       (princ "\n")
    
30.       (princ nm0)
    
31.       (princ "个物体不是POLYLINE,")
    
32.       (PRINC nm)
    
33.       (princ "个物体不是封闭的POLYLINE,已换至0层，请编辑后重新计算")
    
34.       )
    
35.      (PROGN
    
36.      (setq m 0)
    
37.      (setq total 0)
    
38.       (while (< m n )
    
39.         (setq s1 (ssname ss1 m))
    
40.         (command "area" "e" s1)
    
41.         (setq aaaa (getvar "area"))
    
42.         (setq total ( + total aaaa))
    
43.         (setq m (+ 1 m))
    
44.       )
    
45.      (princ "\n 总面积为")
    
46.      (princ total)
    
47.      )
    
48. )
    
49. (SETQ SS1 NiL)
    
50. (setvar "cmdecho" 1)
    
51. (princ)
    
52. )

(defun c:warea()<br /> (setvar "cmdecho" 0) <br /> (SETQ SS1 (SSGET))<br /> (setq n (SSlength ss1))<br /> (setq m 0)<br /> (setq nm 0)<br /> (SETQ nm0 0)<br /> (while (< m n )<br />        (setq s1 (ssname ss1 m))<br />        (SETQ SSL (ENTGET  S1))<br />        (IF (/= (CDR (ASSOC 0 SSL)) "LWPOLYLINE")<br />           (progn<br />           (command "change" s1 "" "p" "la" "0" "")<br />           (setq nm0 (+ 1 nm0))<br />           )<br />        )<br />        (if (= (cdr (assoc 70  SSL)) 0)<br />           (progn<br />           (command "change" s1 "" "p" "la" "0" "")<br />           (setq nm (+ 1 nm))<br />           )<br />       )<br />      (setq m (+ 1 m))<br />   )<br /> <br /> (if (or (/= nm 0) (/= nm0 0))<br />       (progn <br />       (princ "\n")<br />       (princ nm0)<br />       (princ "个物体不是POLYLINE,")<br />       (PRINC nm)<br />       (princ "个物体不是封闭的POLYLINE,已换至0层，请编辑后重新计算") <br />       )<br />      (PROGN<br />      (setq m 0)<br />      (setq total 0)<br />       (while (< m n )<br />         (setq s1 (ssname ss1 m))<br />         (command "area" "e" s1)<br />         (setq aaaa (getvar "area"))<br />         (setq total ( + total aaaa))<br />         (setq m (+ 1 m))<br />       )<br />      (princ "\n 总面积为")<br />      (princ total)<br />      )<br /> )<br /> (SETQ SS1 NiL)<br /> (setvar "cmdecho" 1)<br /> (princ)<br /> )

陌生人

给个参考，还可自己加点东西

2. 
   
3. (defun c:ssarea (/ ss e obj lst)
   
4.   (setq ss (ssget))
   
5.   (repeat (setq n (sslength ss))
   
6.     (setq e  (ssname ss (setq n (1- n)))
   
7.           obj(vlax-ename->vla-object e))
   
8.     (if (vlax-property-available-P obj 'area);可加是否闭合的判断.
   
9.         (setq lst (cons (list e (vlax-get obj 'area)) lst))
   
10.     )
    
11.   )(list (apply '+ (mapcar '(lambda(x) (cadr x)) lst)) lst)
    
12. )

<br /> (defun c:ssarea (/ ss e obj lst)<br />   (setq ss (ssget))<br />   (repeat (setq n (sslength ss))<br />     (setq e  (ssname ss (setq n (1- n)))<br />           obj(vlax-ename->vla-object e))<br />     (if (vlax-property-available-P obj 'area);可加是否闭合的判断.<br />         (setq lst (cons (list e (vlax-get obj 'area)) lst))<br />     )<br />   )(list (apply '+ (mapcar '(lambda(x) (cadr x)) lst)) lst)<br /> )

eachy

最初由 陌生人 发布
[B]给个参考，还可自己加点东西
(defun c:ssarea (/ ss e obj lst)
  (setq ss (ssget))
  (repeat (setq n (sslength ss))
    (setq e  (ssname ss (setq n (1- n)))
          obj(vlax-ename->vla-object e))... [/B]

2. 
   
3. (defun c:test (/ ss n a aa)
   
4.   (if (setq ss (ssget))
   
5.     (progn
   
6.       (setq n 0
   
7.             a 0
   
8.       )
   
9.       (repeat (sslength ss)
   
10.         (if (setq aa (vlax-curve-getarea (ssname ss n )))
    
11.           (setq a (+ a aa))
    
12.         )
    
13.         (setq n (1+ n))
    
14.       )
    
15.     )
    
16.   )
    
17.   (princ "Area = ")
    
18.   (princ a)
    
19.   (princ)
    
20. )

<br /> (defun c:test (/ ss n a aa)<br />   (if (setq ss (ssget))<br />     (progn<br />       (setq n 0<br />             a 0<br />       )<br />       (repeat (sslength ss)<br />         (if (setq aa (vlax-curve-getarea (ssname ss n )))<br />           (setq a (+ a aa))<br />         )<br />         (setq n (1+ n))<br />       )<br />     )<br />   )<br />   (princ "Area = ")<br />   (princ a)<br />   (princ)<br /> )