[LISP程序]：累计封闭Pline,Hatch(autocad2006+)等面积

eachy

2. 
   
3. ;;累计封闭Pline、Spline，Region,Circle,Hatch(autocad2006+)面积
   
4. ;;对Hatch计算时有错误提示
   
5. ;;Form [url]www.xdcad.net[/url] eachy 2005.9.23
   
6. (defun c:CalArea (/ ss _area m)
   
7.   ;(xd-begin nil);_ Begin Mark
   
8.   (if (setq ss (ssget (list '(-4 . "<or")
   
9.                             '(0 . "region,circle,hatch") ;_Region circle hatch
   
10.                             '(-4 . "<and")
    
11.                             '(0 . "ellipse")
    
12.                             '(41 . 0.)
    
13.                             (cons 42 (* pi 2))
    
14.                             '(-4 . "and>") ;_totle ellipse
    
15.                             '(-4 . "<and")
    
16.                             '(0 . "*polyline,spline")
    
17.                             '(-4 . "&=")
    
18.                             '(70 . 1);_closed
    
19.                             '(-4 . "and>")
    
20.                             '(-4 . "or>")
    
21.                       )
    
22.                )
    
23.       )
    
24.     (progn
    
25.       (setq _area 0.
    
26.             m 0
    
27.       )
    
28.       (xd-ssmap
    
29.         '(lambda (e / area typ)
    
30.            (setq area (vl-catch-all-apply 'vlax-curve-getarea (list e))
    
31.                  typ  (cdr (assoc 0 (entget e)))
    
32.            )
    
33.            (if (= typ "HATCH")
    
34.              (setq area        (vl-catch-all-apply
    
35.                           'vla-get-area
    
36.                           (list (vlax-ename->vla-object e))
    
37.                         )
    
38.              );_ 可能为 0 或 error in cad2006-
    
39.              (setq
    
40.                area (vl-catch-all-apply 'vlax-curve-getarea (list e))
    
41.              );_ get area of curve
    
42.            )
    
43.            (if (or (vl-catch-all-error-p area);_ befor CAD2006
    
44.                    (zerop area);_ error
    
45.                );_错误检测，不包括自相交的Pline Spline
    
46.              (progn (redraw e 3)
    
47.                     (setq m (1+ m))
    
48.              )
    
49.              (setq _area (+ _area area));_可以根据单位自调
    
50.            )
    
51.          )
    
52.         ss
    
53.       )
    
54.       (princ "\nTotle Area = ")
    
55.       (princ _area)
    
56.       (if (not (zerop m))
    
57.         (princ (strcat "\nTotle " (itoa m) " Entity Can not Cal Area!"))
    
58.       );_错误提示
    
59.     )
    
60.   )
    
61.   ;;(xd-end);_End Mark
    
62.   (princ)
    
63. )
    
64. (princ "\nStart Command With CalArea. eachy [[url]www.xdcad.net[/url]]!")
    
65. (princ)
    

<br /> ;;累计封闭Pline、Spline，Region,Circle,Hatch(autocad2006+)面积<br /> ;;对Hatch计算时有错误提示<br /> ;;Form [url]www.xdcad.net[/url] eachy 2005.9.23<br /> (defun c:CalArea (/ ss _area m)<br />   ;(xd-begin nil);_ Begin Mark<br />   (if (setq ss (ssget (list '(-4 . "<or")<br />                             '(0 . "region,circle,hatch") ;_Region circle hatch<br />                             '(-4 . "<and")<br />                             '(0 . "ellipse")<br />                             '(41 . 0.)<br />                             (cons 42 (* pi 2))<br />                             '(-4 . "and>") ;_totle ellipse<br />                             '(-4 . "<and")<br />                             '(0 . "*polyline,spline")<br />                             '(-4 . "&=")<br />                             '(70 . 1);_closed<br />                             '(-4 . "and>")<br />                             '(-4 . "or>")<br />                       )<br />                )<br />       )<br />     (progn<br />       (setq _area 0.<br />             m 0<br />       )<br />       (xd-ssmap<br />         '(lambda (e / area typ)<br />            (setq area (vl-catch-all-apply 'vlax-curve-getarea (list e))<br />                  typ  (cdr (assoc 0 (entget e)))<br />            )<br />            (if (= typ "HATCH")<br />              (setq area        (vl-catch-all-apply<br />                           'vla-get-area<br />                           (list (vlax-ename->vla-object e))<br />                         )<br />              );_ 可能为 0 或 error in cad2006-<br />              (setq<br />                area (vl-catch-all-apply 'vlax-curve-getarea (list e))<br />              );_ get area of curve<br />            )<br />            (if (or (vl-catch-all-error-p area);_ befor CAD2006<br />                    (zerop area);_ error<br />                );_错误检测，不包括自相交的Pline Spline<br />              (progn (redraw e 3)<br />                     (setq m (1+ m))<br />              )<br />              (setq _area (+ _area area));_可以根据单位自调<br />            )<br />          )<br />         ss<br />       )<br />       (princ "\nTotle Area = ")<br />       (princ _area)<br />       (if (not (zerop m))<br />         (princ (strcat "\nTotle " (itoa m) " Entity Can not Cal Area!"))<br />       );_错误提示<br />     )<br />   )<br />   ;;(xd-end);_End Mark<br />   (princ)<br /> )<br /> (princ "\nStart Command With CalArea. eachy [[url]www.xdcad.net[/url]]!")<br /> (princ)<br />

zzqxuexicad

Command:
CALAREA
Select objects: 1 found
Select objects: 1 found, 2 total
Select objects: 1 found, 3 total
Select objects:
错误: no function definition: XD-SSMAP

bridgewind

最初由 zzqxuexicad 发布
[B]Command:
CALAREA
Select objects: 1 found
Select objects: 1 found, 2 total
Select objects: 1 found, 3 total
Select objects:
错误: no function definition: XD-SSMAP [/B]

加载小东库即可。。

tow

有甚麼用啊LZ？

god1478

呵呵  都是快捷的东西 果然实用 呵呵

fu2046

这个方法不错。。以后不用放大在放大了

littleq

反正还是看不懂啊

asdfafasdfadf

下下来试试。

evilweng

感谢楼主

ljh19991220

好像有问题。

xhbhh

看不懂