[LISP程序]：计算任意封闭图形面积的LISP小程序

梦断江南

好好想想，追踪一下新生成的实体的规律，就可以解决孤岛问题了：）继续努力

shisj

最初由 xiaping 发布
[B]
你把这一行代码(... [/B]

谢谢了，我也发现了是我设置的问题，将设置更改就没有问题了，谢谢了。

gdqbx

要是能把求得的面积标到图上就更好了。

它山之石

回了几次头了，就试试我的这个程序吧。
可以去除孤岛面积。当时写这个程序是为了求出条形基础的净面积。
后面的程序是设定相关参数的。主要是出图比例、绘图比例及显示的单位。

2. 
   
3. (defun C:jmj (/        ss sss sc os xzs pt n stm stmm mj_txt mjm_txt mjj_txt
   
4.               test)
   
5. 
   
6.   (princ (strcat "\n***基底面积自动计算软件040201  葛磊***"))
   
7.   (princ (strcat "\n        [共享软件，版权所有]"))
   
8.   (princ)
   
9. 
   
10.   (command "undo" "be")
    
11.   (setq        olderr        *error*                        ; Initialize variables
    
12.         *error*        chgterr
    
13.   )
    
14.   (setvar "CMDECHO" 0)
    
15. 
    
16.   (setq os (getvar "OSMODE"))
    
17.   (setvar "OSMODE"
    
18.           (if (> os 16383)
    
19.             os
    
20.             (+ 16384 os)
    
21.           )
    
22.   )
    
23.   (setq lay (getvar "clayer"))
    
24.   (if mj_sc
    
25.     (setq mj_sc mj_sc)
    
26.     (setq mj_sc 1000000)
    
27.   )
    
28.   (if xd
    
29.     (setq xd xd)
    
30.     (setq xd "m")
    
31.   )
    
32. 
    
33.   (if (or (= nil (tblsearch "layer" "文字__面积"))
    
34.           (/= (cdr (assoc 8 (tblsearch "layer" "文字__面积"))) 0)
    
35.       )
    
36.     (command "layer" "m" "文字__面积" "c" "255" "文字__面积" "")
    
37.     (command "layer" "s" "文字__面积" "" "")
    
38.   )
    
39. ;;; 如果图中原有面域则删除
    
40.   (setq ss (ssget "X" '((0 . "REGION"))))
    
41.   (if ss
    
42.     (command "erase" ss "")
    
43.   )
    
44. 
    
45.   (setq pt (getpoint "\n请点取基底范围内一点<退出>:"))
    
46.   (if pt
    
47.     (progn
    
48.       (setvar "HPBOUND" 0)
    
49.       (command "boundary" pt "")
    
50.       (setq ss (ssget "X" '((0 . "REGION"))))
    
51. 
    
52. 
    
53. 
    
54.       (if ss                                ; 如果选取到了实体
    
55.         (progn
    
56.           (setq xzs (sslength ss))
    
57.           (setq mjm_txt 0)                ;mj_txt---重叠面积
    
58. 
    
59.           (setq n 1)                        ;n---实体数
    
60.           (while (<= n xzs)                ;对选取的实体逐个进行处理
    
61.             (setq stm (ssname ss (1- n))) ;stm---实体名称
    
62.             (command "area" "o" stm)
    
63.             (setq mjj_txt (getvar "AREA")) ;mj_txt---重叠面积
    
64.             (if        (< mjm_txt Mjj_txt)
    
65.               (setq stmm    stm
    
66.                     Mjm_txt Mjj_txt
    
67.               )
    
68.             )
    
69.             (setq n (+ 1 n))                ;下一个实体
    
70.           )                                ;while
    
71. 
    
72. 
    
73.           (setq sss (ssadd))                ;ss---获得生成的面域实体
    
74.           (setq sss (ssadd stmm sss))        ;获得生成的面域实体
    
75.           (setq ss (ssdel stmm ss))        ;获得生成的面域实体
    
76.           (if (< 1 xzs)
    
77.             (command "subtract" sss "" ss "")
    
78.           )                                ;如果获得了一个以上的面域，则生成交集。
    
79.           (command "area" "o" (entlast)) ;获得交集的面积
    
80.           (setq mj_txt (getvar "AREA"))        ;mj_txt---交集面积
    
81.           (setq mj_txt (rtos (/ mj_txt mj_sc) 2 2))
    
82.           (setq mjm_txt (rtos (/ mjm_txt mj_sc) 2 2))
    
83.           (cond        ((or (eq xd "mm") (eq xd "MM"))
    
84.                  (alert        (strcat        "基底外包面积为: "
    
85.                                 mjm_txt
    
86.                                 " 平方毫米   基底净面积为: "
    
87.                                 mj_txt
    
88.                                 " 平方毫米"
    
89.                                )
    
90.                  )
    
91.                 )
    
92.                 ((or (eq xd "cm") (eq xd "CM"))
    
93.                  (alert        (strcat        "基底外包面积为: "
    
94.                                 mjm_txt
    
95.                                 " 平方厘米   基底净面积为: "
    
96.                                 mj_txt
    
97.                                 " 平方厘米"
    
98.                                )
    
99.                  )
    
100.                 )
     
101.                 ((or (eq xd "m") (eq xd "M"))
     
102.                  (alert        (strcat        "基底外包面积为: "
     
103.                                 mjm_txt
     
104.                                 " 平方米   基底净面积为: "
     
105.                                 mj_txt
     
106.                                 " 平方米"
     
107.                                )
     
108.                  )
     
109.                 )
     
110.           )
     
111. 
     
112. 
     
113.         )                                ;progn ss
     
114.         (alert (strcat "\n无法得到正确的基底边界"))
     
115. 
     
116.       )                                        ;if ss
     
117.     )                                        ;progn pt
     
118.   )                                        ;if pt
     
119. 
     
120.   (command "layer" "s" lay "")
     
121.   (setvar "osmode" os)
     
122.   (setq *error* olderr)                        ; Restore old *error* handler
     
123.   (command "undo" "e")
     
124.   (command "undo" "")
     
125. 
     
126.   (princ (strcat "\n***基底面积自动计算软件040201  葛磊***"))
     
127.   (princ (strcat "\n        [共享软件，版权所有]"))
     
128.   (princ)
     
129. )
     
130. 
     

<br /> (defun C:jmj (/        ss sss sc os xzs pt n stm stmm mj_txt mjm_txt mjj_txt<br />               test)<br /> <br />   (princ (strcat "\n***基底面积自动计算软件040201  葛磊***"))<br />   (princ (strcat "\n        [共享软件，版权所有]"))<br />   (princ)<br /> <br />   (command "undo" "be")<br />   (setq        olderr        *error*                        ; Initialize variables<br />         *error*        chgterr<br />   )<br />   (setvar "CMDECHO" 0)<br /> <br />   (setq os (getvar "OSMODE"))<br />   (setvar "OSMODE"<br />           (if (> os 16383)<br />             os<br />             (+ 16384 os)<br />           )<br />   )<br />   (setq lay (getvar "clayer"))<br />   (if mj_sc<br />     (setq mj_sc mj_sc)<br />     (setq mj_sc 1000000)<br />   )<br />   (if xd<br />     (setq xd xd)<br />     (setq xd "m")<br />   )<br /> <br />   (if (or (= nil (tblsearch "layer" "文字__面积"))<br />           (/= (cdr (assoc 8 (tblsearch "layer" "文字__面积"))) 0)<br />       )<br />     (command "layer" "m" "文字__面积" "c" "255" "文字__面积" "")<br />     (command "layer" "s" "文字__面积" "" "")<br />   )<br /> ;;; 如果图中原有面域则删除<br />   (setq ss (ssget "X" '((0 . "REGION"))))<br />   (if ss<br />     (command "erase" ss "")<br />   )<br /> <br />   (setq pt (getpoint "\n请点取基底范围内一点<退出>:"))<br />   (if pt<br />     (progn<br />       (setvar "HPBOUND" 0)<br />       (command "boundary" pt "")<br />       (setq ss (ssget "X" '((0 . "REGION"))))<br /> <br /> <br /> <br />       (if ss                                ; 如果选取到了实体<br />         (progn<br />           (setq xzs (sslength ss))<br />           (setq mjm_txt 0)                ;mj_txt---重叠面积<br /> <br />           (setq n 1)                        ;n---实体数<br />           (while (<= n xzs)                ;对选取的实体逐个进行处理<br />             (setq stm (ssname ss (1- n))) ;stm---实体名称<br />             (command "area" "o" stm)<br />             (setq mjj_txt (getvar "AREA")) ;mj_txt---重叠面积<br />             (if        (< mjm_txt Mjj_txt)<br />               (setq stmm    stm<br />                     Mjm_txt Mjj_txt<br />               )<br />             )<br />             (setq n (+ 1 n))                ;下一个实体<br />           )                                ;while<br /> <br /> <br />           (setq sss (ssadd))                ;ss---获得生成的面域实体<br />           (setq sss (ssadd stmm sss))        ;获得生成的面域实体<br />           (setq ss (ssdel stmm ss))        ;获得生成的面域实体<br />           (if (< 1 xzs)<br />             (command "subtract" sss "" ss "")<br />           )                                ;如果获得了一个以上的面域，则生成交集。<br />           (command "area" "o" (entlast)) ;获得交集的面积<br />           (setq mj_txt (getvar "AREA"))        ;mj_txt---交集面积<br />           (setq mj_txt (rtos (/ mj_txt mj_sc) 2 2))<br />           (setq mjm_txt (rtos (/ mjm_txt mj_sc) 2 2))<br />           (cond        ((or (eq xd "mm") (eq xd "MM"))<br />                  (alert        (strcat        "基底外包面积为: "<br />                                 mjm_txt<br />                                 " 平方毫米   基底净面积为: "<br />                                 mj_txt<br />                                 " 平方毫米"<br />                                )<br />                  )<br />                 )<br />                 ((or (eq xd "cm") (eq xd "CM"))<br />                  (alert        (strcat        "基底外包面积为: "<br />                                 mjm_txt<br />                                 " 平方厘米   基底净面积为: "<br />                                 mj_txt<br />                                 " 平方厘米"<br />                                )<br />                  )<br />                 )<br />                 ((or (eq xd "m") (eq xd "M"))<br />                  (alert        (strcat        "基底外包面积为: "<br />                                 mjm_txt<br />                                 " 平方米   基底净面积为: "<br />                                 mj_txt<br />                                 " 平方米"<br />                                )<br />                  )<br />                 )<br />           )<br /> <br /> <br />         )                                ;progn ss<br />         (alert (strcat "\n无法得到正确的基底边界"))<br /> <br />       )                                        ;if ss<br />     )                                        ;progn pt<br />   )                                        ;if pt<br /> <br />   (command "layer" "s" lay "")<br />   (setvar "osmode" os)<br />   (setq *error* olderr)                        ; Restore old *error* handler<br />   (command "undo" "e")<br />   (command "undo" "")<br /> <br />   (princ (strcat "\n***基底面积自动计算软件040201  葛磊***"))<br />   (princ (strcat "\n        [共享软件，版权所有]"))<br />   (princ)<br /> )<br /> <br />

2. 
   
3. (defun C:mjs (/ ctscale htccale xdw xdws)
   
4.   (setvar "CMDECHO" 0)
   
5. 
   
6.   (if (= cts nil)
   
7.     (setq cts 100)
   
8.   )
   
9.   (setq
   
10.     ctscale (getreal (strcat "\n出图比例(1:?) <" (rtos cts 2 0) ">:"))
    
11.   )
    
12.   (if (= ctscale nil)
    
13.     (setq ctscale cts)
    
14.   )
    
15.   (setq cts ctscale)
    
16. 
    
17.   (if (= htc nil)
    
18.     (setq htc 100)
    
19.   )
    
20.   (setq
    
21.     htccale (getreal (strcat "\n绘图比例(1:?) <" (rtos htc 2 0) ">:"))
    
22.   )
    
23.   (if (= htccale nil)
    
24.     (setq htccale htc)
    
25.   )
    
26.   (setq htc htccale)
    
27. 
    
28.   (if (or (= xd nil) (= xd ""))
    
29.     (setq xd "M")
    
30.   )
    
31.   (setq xdw (getstring (strcat "\n显示单位 <" xd ">:")))
    
32.   (if (= xdw "")
    
33.     (setq xdw xd)
    
34.   )
    
35.   (setq xd xdw)
    
36.   (cond        ((or (eq xdw "mm") (eq xdw "MM")) (setq xdws 1))
    
37.         ((or (eq xdw "cm") (eq xdw "CM")) (setq xdws 1000))
    
38.         ((or (eq xdw "m") (eq xdw "M")) (setq xdws 1000000))
    
39.   )
    
40.   (setq mj_sc (* (* (/ ctscale htccale) (/ ctscale htccale)) xdws))
    
41.   (princ)
    
42. 
    
43. )
    
44. 
    
45. 
    

<br /> (defun C:mjs (/ ctscale htccale xdw xdws)<br />   (setvar "CMDECHO" 0)<br /> <br />   (if (= cts nil)<br />     (setq cts 100)<br />   )<br />   (setq<br />     ctscale (getreal (strcat "\n出图比例(1:?) <" (rtos cts 2 0) ">:"))<br />   )<br />   (if (= ctscale nil)<br />     (setq ctscale cts)<br />   )<br />   (setq cts ctscale)<br /> <br />   (if (= htc nil)<br />     (setq htc 100)<br />   )<br />   (setq<br />     htccale (getreal (strcat "\n绘图比例(1:?) <" (rtos htc 2 0) ">:"))<br />   )<br />   (if (= htccale nil)<br />     (setq htccale htc)<br />   )<br />   (setq htc htccale)<br /> <br />   (if (or (= xd nil) (= xd ""))<br />     (setq xd "M")<br />   )<br />   (setq xdw (getstring (strcat "\n显示单位 <" xd ">:")))<br />   (if (= xdw "")<br />     (setq xdw xd)<br />   )<br />   (setq xd xdw)<br />   (cond        ((or (eq xdw "mm") (eq xdw "MM")) (setq xdws 1))<br />         ((or (eq xdw "cm") (eq xdw "CM")) (setq xdws 1000))<br />         ((or (eq xdw "m") (eq xdw "M")) (setq xdws 1000000))<br />   )<br />   (setq mj_sc (* (* (/ ctscale htccale) (/ ctscale htccale)) xdws))<br />   (princ)<br /> <br /> )<br /> <br /> <br />

hisen

谢谢了，收下你的程序了，研究一下。

xxxyzxx

晕，虽然我的版本比1楼楼主的新，但19楼楼主写得好全，似乎比我的版本还新，我去研究一下
－－－－－－－－－－－－－－－－－－－－－－－－－－－－

houxianyong

19楼的东东不错，但是用BOUNDARY命令不是很保险，当实体高度不一致的时候会失败

xyp1964

试试：http://www.xdcad.net/forum/showthread.php?s=&threadid=272117

sdwy19691229

是厉害，受教了。

zb_lou

我正好想编一个这样的程序，受到很大启发。非常感谢！！

kill99

楼主可以再修改一下，能支持比例尺就更好了