[LISP程序]：计算选定对象的"总面积"和"总长度"

dg_lcl

;;; AREAM.LSP
;;; Function: Calculates the total area of selected objects
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2002 JTB World, All Rights Reserved
;;; Website: www.jtbworld.com / http://jtbworld.vze.com
;;; E-mail: info@jtbworld.com / jtbworld@hotmail.com
;;; Tested on AutoCAD 2000

(defun c:aream (/ olderr oldcmdecho errexit undox restore ss1 nr en tot_area)
  (defun errexit (s)
    (restore)
  )

  (defun undox ()
    (command "._undo" "_E")
    (setvar "cmdecho" oldcmdecho)
    (setq *error* olderr)
    (princ)
  )

  (setq olderr  *error*
        restore undox
        *error* errexit
  )
  (setq oldcmdecho (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (command "._UNDO" "_BE")
  (if (setq ss1 (ssget '((-4 . "<OR")
                         (0 . "POLYLINE")
                         (0 . "LWPOLYLINE")
                         (0 . "CIRCLE")
                         (0 . "ELLIPSE")
                         (0 . "SPLINE")
                         (0 . "REGION")
                         (-4 . "OR>")
                        )
                )
      )
    (progn
      (setq nr 0)
      (setq tot_area 0.0)
      (setq en (ssname ss1 nr))
      (while en
        (command "._area" "_O" en)
        (setq tot_area (+ tot_area (getvar "area")))
        (setq nr (1+ nr))
        (setq en (ssname ss1 nr))
      )
      (princ "\nTotal Area = ")
      (princ tot_area)
    )
  )
  (restore)
)

;;;明经通道

lockmyeye

;;;修改修改

(DEFUN c:aream (/ num1 ss1 tot_area)
    (SETVAR "useri1" (GETVAR "cmdecho"))
    (SETVAR "cmdecho" 0)
    (IF (SETQ tot_area 0.0
              num1     -1
              ss1      (SSGET '((0 . "POLYLINE,LWPOLYLINE,CIRCLE,ELLIPSE,SPLINE,SPLINE,REGION")))
        )
        (PROGN (COMMAND "area" "a" "o")
               (REPEAT (SSLENGTH ss1) (COMMAND (SSNAME ss1 (SETQ num1 (1+ num1)))))
               (COMMAND "" "")
               (PRINC (STRCAT "\nTotal Area = " (RTOS (GETVAR "area") 2)))
        )
    )
    (SETVAR "cmdecho" (GETVAR "useri1"))
    (PRINC)
)

lsjjm

我也来一个:

(defun c:test ()
  (vl-load-com)
  (setq ss (ssget))
  (setq sum 0 n 0)
  (while (< n (sslength ss))
    (setq obj (vlax-ename->vla-object (ssname ss n)))
    (if (vlax-property-available-p obj "area")
      (setq sum (+ sum (vla-get-area obj)))
    )
    (setq n (1+ n))
  )
  sum
)

秋枫

2. 
   
3. [FONT=courier new]
   
4. (defun c:TOTALAREA (/ ss e alist)
   
5.   (vl-load-com)
   
6.   (ssmap '(lambda (e)
   
7.             (setq alist (cons (vla-get-area (vlax-ename->vla-object e)) alist))
   
8.           )
   
9.          (ssget '((0 . "POLYLINE,LWPOLYLINE,CIRCLE,ELLIPSE,SPLINE,SPLINE,REGION")))
   
10.   )
    
11.   (princ "\n总面积：")
    
12.   (apply '+ alist)
    
13. )
    
14. [/FONT]

<br /> [FONT=courier new]<br /> (defun c:TOTALAREA (/ ss e alist)<br />   (vl-load-com)<br />   (ssmap '(lambda (e)<br />             (setq alist (cons (vla-get-area (vlax-ename->vla-object e)) alist))<br />           )<br />          (ssget '((0 . "POLYLINE,LWPOLYLINE,CIRCLE,ELLIPSE,SPLINE,SPLINE,REGION")))<br />   )<br />   (princ "\n总面积：")<br />   (apply '+ alist)<br /> )<br /> [/FONT]

其中ssmap是通用函数：

2. 
   
3. [FONT=courier new]
   
4. ;;; Apply a function to each ent in ss, in reversed order
   
5. ;;; Faster than with std-sslist, but not so easy to understand.
   
6. ;;; Ex: (ssmap 'entupd (ssget))   ; regenerate only some entities
   
7. (defun SSMAP (func ss / n)
   
8.   (if (eq 'PICKSET (type ss))
   
9.     (repeat (setq n (fix (sslength ss))) ; fixed
   
10.       (apply func (list (ssname ss (setq n (1- n)))))
    
11.     )
    
12.   )
    
13. )[/FONT]

<br /> [FONT=courier new]<br /> ;;; Apply a function to each ent in ss, in reversed order<br /> ;;; Faster than with std-sslist, but not so easy to understand.<br /> ;;; Ex: (ssmap 'entupd (ssget))   ; regenerate only some entities<br /> (defun SSMAP (func ss / n)<br />   (if (eq 'PICKSET (type ss))<br />     (repeat (setq n (fix (sslength ss))) ; fixed<br />       (apply func (list (ssname ss (setq n (1- n)))))<br />     )<br />   )<br /> )[/FONT]

aeo

r14还是用第一贴吧.

总面积:

2. 
   
3. (defun c:totalarea( / ss all j)
   
4. (if(setq all 0 j -1 ss(ssget '((0 . "*POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION,ARC"))))
   
5.    (repeat(sslength ss)
   
6.        (setq all(+ all(vla-get-area (vlax-ename->vla-object (ssname ss(setq j(1+ j)))) )))
   
7.   ))
   
8. (princ (strcat "\n总面积："(rtos all 2 3)))
   
9. (princ)
   
10. )
    

<br /> (defun c:totalarea( / ss all j)<br /> (if(setq all 0 j -1 ss(ssget '((0 . "*POLYLINE,CIRCLE,ELLIPSE,SPLINE,REGION,ARC"))))<br />    (repeat(sslength ss)<br />        (setq all(+ all(vla-get-area (vlax-ename->vla-object (ssname ss(setq j(1+ j)))) )))<br />   ))<br /> (princ (strcat "\n总面积："(rtos all 2 3)))<br /> (princ)<br /> )<br />

总长度:

2. 
   
3.   (defun c:totallen( / ss all j)
   
4. (if(setq all 0 j -1 ss(ssget '((0 . "*LINE,CIRCLE,ELLIPSE,ARC,REGION"))))
   
5.    (repeat(sslength ss)
   
6.        (setq all(+ all(vlax-curve-getDistAtParam
   
7.                         (setq e(vlax-ename->vla-object(ssname ss(setq j(1+ j)))))
   
8.                           (vlax-curve-getEndParam e)
   
9.                       )
   
10.                        
    
11.         ))
    
12.   ))
    
13. (princ (strcat "\n总长度："(rtos all 2 3)))
    
14. (princ)
    
15. )
    

<br />   (defun c:totallen( / ss all j)<br /> (if(setq all 0 j -1 ss(ssget '((0 . "*LINE,CIRCLE,ELLIPSE,ARC,REGION"))))<br />    (repeat(sslength ss)<br />        (setq all(+ all(vlax-curve-getDistAtParam<br />                         (setq e(vlax-ename->vla-object(ssname ss(setq j(1+ j)))))<br />                           (vlax-curve-getEndParam e)<br />                       )<br />                        <br />         ))<br />   ))<br /> (princ (strcat "\n总长度："(rtos all 2 3)))<br /> (princ)<br /> )<br />

f5612140

1.為何版主只對4樓樓主獎勵?只因該程序看起來較有水準?
2.lwpolyline,spline,arc在非閉合的情況下也能求得面積,但其真正的含意?
3.程序中能將同性質分別統計更佳

aeo

这种东东网上找找一大把:-)

2.没面积就为0。(自动闭合后的面积)

我加分是秋枫提供了另一种对付选集的方法，虽然他也不是原创,但我希望大家用之.

f5612140

最初由 aeo 发布
[B]2.没面积就为0。(自动闭合后的面积)[/B]

個人以為,以實務考量,在非閉合的情形下,應將該面積剔除

lsjjm

最初由 f5612140 发布
[B]

個人以為,以實務考量,在非閉合的情形下,應將該面積剔除 [/B]

有个这样的例子, 一个农夫修了几个羊圈, 暂时还没有装门(也就是说不封闭), 那么这时要问这几个羊圈占地面积是多少? 你能说这些面积应剔除吗?
--不要只从纯数学的角度来理解, CAD就是那么规定的...

f5612140

最初由 lsjjm 发布
[B]
有个这样的例子, 一个农夫修了几个羊圈, 暂时还没有装门(也就是说不封闭), 那么这时要问这几个羊?.. [/B]

1.何不等羊圈的門弄好再說,更何況有的才剛弄羊圈就說這塊地是我的
2.每個人的需求不一樣,程序設計中又沒有分類統計,做出來的只是一個數字,圖面上多畫一個lwpolyline,或一個arc就得到不同的結果,不是想和您抬槓,只是提供出來討論,讓程序設計時考慮的更嚴謹而已
3.cad只是一個工具,並沒有規定這樣得到的結果就要接受它

aeo

最初由 f5612140 发布
[B]
讓程序設計時考慮的更嚴謹而已...
[/B]

我们这里只讨论怎么实现，至于考虑的问题全面不全面，写的时候大家都明白.
如果只是想要一个程序，而不是交流lisp,请到"编程申请"板块.

f5612140

最初由 aeo 发布
[B]

我们这里只讨论怎么实现，至于考虑的问题全面不全面，写的时候大家都明白.
如果只是想要一个程序，而不是交流lisp,请... [/B]

1.只是好心提醒,卻得到這般態度
2.您確定寫的人,用的人都明白
3.我自己專攻工程估算,這些東西我都用到爛了,我還會把他當寶?
4.此板塊回應至此,祝你們玩的愉快

陌生人

兄弟,别走啊.我个人以为你对事情严谨的态度是值得钦佩的.我支持你.
也希望有一个程序能在判断上加是否闭合的功能,这样看起来总是更完善些 :)

lsjjm

最初由 陌生人 发布
[B]...也希望有一个程序能在判断上加是否闭合的功能,这样看起来总是更完善些 :) [/B]

判断曲线闭合的贴子有不少啊, 请搜索一下.

zjdtm

那位大侠能在自己的程序上加个功能，在统计面积时，把没有闭合的物体标记出来，比如换个图层。