[求助]：LISP编程，一次性选中几个封闭的线，能分别算出各自的面积吗？

寒光四射

用LISP编程，（输入一个程序命令执行）选中几个封闭的线，能自动算出面积吗？
比如大封闭线里面有个小封闭线，算出大封闭线内面积（所包围的全部，包括小封闭线内的），也算出小封闭线面积。

补充：不是一个一个地去选择封闭线，而是一次性选择，出来的结果分别写出来（排成一排），
比如：9.001
            10.202
            13.789
             16.988

请高手出招相助

taner

vlax-curve-getArea

zml84

http://www.acad.net.cn/viewthread.php?tid=151&extra=page%3D1
第二楼附件下载
<br>
面积反应器：http://www.acad.net.cn/viewthread.php?tid=157&extra=page%3D3

寒光四射

反应器？
感觉好复杂啊，有没有简单的LISP程序？
麻烦高手编写一个让我们来学习啊

zexib

谢谢啊.那个高手编好了也给我一个啊.

TLHMQH

(defun c:QMJ ( / en pt txt)
(IF (tblsearch "STYLE" "CHINA")
(setvar "TEXTSTYLE" "CHINA")
(command "_style" "CHINA" "simplex,china" "" "1" "" "" "" "")
)
(while (setq pt (getpoint "\n选取点: "))
(command "-BOUNDARY" pt "")
(setq en (entlast))
(if (/= en nil)
(progn
(command "area" "o" en)
(command "layer" "m" "tmp" "c" "1" "" "")
(command "chprop" en "" "la" "tmp" "")
(setq txt (strcat (rtos (/ (getvar "area") 10000) 2 3) "㎡")
)
(command "layer" "m" "AREA-㎡" "c" "4" "" "")
(command "text" "j" "MC" pt "30" "0" txt)
)
)
))

寒光四射

谢谢楼主啊，
看你的程序，好象是一个一个地选择封闭线，
我的意思，不要一个一个地选择，框选或线选，
被选中的封闭线就自动算出各自的封闭面积并写出来。

cgh93001

(defun c:QMJ ( / en pt txt)
        (command "layer" "m" "tmp" "c" "1" "" "")
        (setq ss (ssget) )
            (if ss
             (progn
                (SETQ NUM (sslength ss) i 0)
                (WHILE (< i NUM)
                   (setq ss1 (ssname ss i) PT (CDR (ASSOC 10 (ENTGET SS1))))
                 (IF PT
                   (PROGN
                       (command "area" "o" SS1)
                     (setq txt (strcat (rtos (getvar "area") 2 3) "㎡"))
                     (command "text" "j" "MC" pt "30" "0" txt)
                   )
                 )   
                   (setq i (1+ i))
              )
            )
       )
   )

xyp1964

2. [FONT=courier new]
   
3. ;;; 实体面积标注
   
4. (defun c:test517 (/ ss i a s1 b)
   
5.   (CMDLASC0)
   
6.   (setq        ss (ssget '((0 . "Arc,Circle,Ellipse,*Polyline,Region,Spline")))
   
7.         i  -1
   
8.         a  0
   
9.   )
   
10.   (xyp-MkLaCo "面积" 3)
    
11.   (while (setq s1 (ssname ss (setq i (1+ i))))
    
12.     (setq b (vla-get-Area (xyp-E2O s1))
    
13.           a (+ a b)
    
14.     )
    
15.     (xyp-Text 5 (xyp-get-MinMaxPoint s1 5) (rtos b 2 3))
    
16.   )
    
17.   (xyp-Text 5 (xyp-get-SSMinMaxPoint ss 5) (strcat "Σ=" (rtos a 2 3)))
    
18.   (CMDLA1)
    
19. )
    
20. [/FONT]

[FONT=courier new]<br /> ;;; 实体面积标注<br /> (defun c:test517 (/ ss i a s1 b)<br />   (CMDLASC0)<br />   (setq        ss (ssget '((0 . "Arc,Circle,Ellipse,*Polyline,Region,Spline")))<br />         i  -1<br />         a  0<br />   )<br />   (xyp-MkLaCo "面积" 3)<br />   (while (setq s1 (ssname ss (setq i (1+ i))))<br />     (setq b (vla-get-Area (xyp-E2O s1))<br />           a (+ a b)<br />     )<br />     (xyp-Text 5 (xyp-get-MinMaxPoint s1 5) (rtos b 2 3))<br />   )<br />   (xyp-Text 5 (xyp-get-SSMinMaxPoint ss 5) (strcat "Σ=" (rtos a 2 3)))<br />   (CMDLA1)<br /> )<br /> [/FONT]

oyxx_1023

如果要执行命令再出结果的话很好办,如果想不执行命令而是一选中对象就得出结果就得用反应器.

carrot1983

没必要用到反应器吧．．．
http://www.cadtutor.net/forum/showthread.php?t=15237
[php]
(defun C:alb (/ acsp adoc ar axss hgt maxp minp obj p1 p2 pc ss txt)

  (vl-load-com)
  (setq        adoc (vla-get-activedocument
               (vlax-get-acad-object)
             )
  )
  (if (and
        (= (getvar "tilemode") 0)
        (= (getvar "cvport") 1)
      )
    (setq acsp (vla-get-paperspace adoc))
    (setq acsp (vla-get-modelspace adoc))
  )
  (vla-startundomark
    (vla-get-activedocument
      (vlax-get-acad-object)
    )
  )
  (initget 7)
  (setq hgt (getreal "\nEnter text height: "))

  (prompt "\nSelect objects on screen to add area label")
  (if (setq ss (ssget))
    (progn

      (setq axss (vla-get-activeselectionset adoc))
      (vlax-for        obj axss
        (if (not
              (vl-catch-all-error-p
                (setq
                  ar (vl-catch-all-apply
                       (function (lambda ()
                                   (vlax-curve-getarea obj)
                                 )
                       )
                     )
                )
              )
            )
          (progn
            (setq txt (strcat "Area = " (rtos ar 2 2)))
            (vla-getboundingbox obj 'minp 'maxp)
            (setq p1 (vlax-safearray->list minp)
                  p2 (vlax-safearray->list maxp)
                  pc (mapcar (function (lambda (a b) (/ (+ a b) 2))) p1 p2)
            )
            (vlax-invoke acsp 'Addtext txt pc hgt)
          )
        )
      )
    )
  )
  (vla-endundomark
    (vla-get-activedocument
      (vlax-get-acad-object)
    )
  )
  (princ)
)
(princ "\nType ALB to label objects with area text")
(princ)
[/php]

寒光四射

我没有表达清楚，所以上面补充了一下，
大家的程序，我去学习研究，谢谢大家，
有什么好的想法、程序，尽管发出来，大家共同进步

qwer2050

学了一招。这儿高手真多啊。。

WSHYDQZ

把选择的东东分别赋予名字就可以了