求高手赐一个批量计算面积的LISP程序

lxh410224

(defun bz()
  (setvar "cmdecho" 0)
  (setq pt (getpoint "\n选取点:"))
  (while pt
    (command "bpoly" pt "")
    (setq en (entlast))
    (if (/= en nil)
      (progn
        (command "area" "o" en)
        (setq aa (getvar "area"))
        (redraw en 3)
        (command "text" "s" "standard" pt  "1" "0" (rtos aa 2 2)))
      )
    (entdel en)
    (setq pt (getpoint "\n选取点:"))
    )
  (prin1)
  )

(defun tc()
  (sub_chk_layer)
   (prin1)
  )
(defun sub_chk_layer ()
  (setq chklay (tblsearch "layer" "C"))
  (if (null chklay)(command "layer" "n" "C" "c" "4" "C" ""))
    (setq chklay (tblsearch "layer" "C2"))
  (if (null chklay)(command "layer" "n" "C2" "c" "4" "C2" ""))
  (setq chklay (tblsearch "layer" "C3"))
  (if (null chklay)(command "layer" "n" "C3" "c" "4" "C3" ""))
  (setq chklay (tblsearch "layer" "B"))
  (if (null chklay)(command "layer" "n" "B" "c" "4" "B" ""))
    (setq chklay (tblsearch "layer" "B2"))
  (if (null chklay)(command "layer" "n" "B2" "c" "4" "B2" ""))
  (setq chklay (tblsearch "layer" "B3"))
  (if (null chklay)(command "layer" "n" "B3" "c" "4" "B3" ""))
   (setq chklay (tblsearch "layer" "B4"))
  (if (null chklay)(command "layer" "n" "B4" "c" "4" "B4" ""))
   (setq chklay (tblsearch "layer" "B5"))
  (if (null chklay)(command "layer" "n" "B5" "c" "4" "B5" ""))
  (setq chklay (tblsearch "layer" "B6"))
  (if (null chklay)(command "layer" "n" "B6" "c" "4" "B6" ""))
  (setq chklay (tblsearch "layer" "B7"))
  (if (null chklay)(command "layer" "n" "B7" "c" "4" "B7" ""))
  (setq chklay (tblsearch "layer" "B8"))
  (if (null chklay)(command "layer" "n" "B8" "c" "4" "B8" ""))
   (setq chklay (tblsearch "layer" "B9"))
  (if (null chklay)(command "layer" "n" "B9" "c" "4" "B9" ""))
   (setq chklay (tblsearch "layer" "A"))
  (if (null chklay)(command "layer" "n" "A" "c" "4" "A" ""))
    (setq chklay (tblsearch "layer" "A2"))
  (if (null chklay)(command "layer" "n" "A2" "c" "4" "A2" ""))
   (setq chklay (tblsearch "layer" "A3"))
  (if (null chklay)(command "layer" "n" "A3" "c" "4" "A3" ""))
   (setq chklay (tblsearch "layer" "A4"))
  (if (null chklay)(command "layer" "n" "A4" "c" "4" "A4" ""))
   (setq chklay (tblsearch "layer" "A5"))
  (if (null chklay)(command "layer" "n" "A5" "c" "4" "A5" ""))
   (setq chklay (tblsearch "layer" "A6"))
  (if (null chklay)(command "layer" "n" "A6" "c" "4" "A6" ""))
   (setq chklay (tblsearch "layer" "A7"))
  (if (null chklay)(command "layer" "n" "A7" "c" "4" "A7" ""))
   (setq chklay (tblsearch "layer" "D"))
  (if (null chklay)(command "layer" "n" "D" "c" "4" "D" ""))
  (setq chklay (tblsearch "layer" "D2"))
  (if (null chklay)(command "layer" "n" "D2" "c" "4" "D2" ""))
   (setq chklay (tblsearch "layer" "厂房1"))
  (if (null chklay)(command "layer" "n" "厂房1" "c" "4" "厂房1" ""))
   (setq chklay (tblsearch "layer" "厂房2"))
  (if (null chklay)(command "layer" "n" "厂房2" "c" "4" "厂房2" ""))
   (setq chklay (tblsearch "layer" "建"))
  (if (null chklay)(command "layer" "n" "建" "c" "4" "建" ""))
)
(defun out ()
  (setvar "cmdecho" 0)
  (setq all 0)
  (setq ss (ssget "x" (list '(0 . "text,mtext") (cons 8  lay))))
  (setq        n 0 k 0)
  (if (/= ss nil)
    (progn
      (repeat (sslength ss)
        (setq en (ssname ss n))
        (setq en_data (entget  en))
        (setq aa (atof (cdr (assoc 1 en_data))))
        (mjljaa)
        (setq n (1+ n))
        )
      )
    (setq k 0 all 0)
    )
  (if (or (/= k 0) (/= all 0))
    (progn
      (if (or (= lay "A")(= lay "B") (= lay "C") (= lay "D"))
        (alert (strcat lay "\房共有<"(itoa k)">栋房子参与了统计，建筑面积为:"(rtos all 2 2)"平方米"))
        (alert (strcat lay "\房共有<"(itoa k)">栋房子参与了统计，建筑面积为:"(rtos (* all (atoi (substr lay 2 2))) 2 2)"平方米"))
        )
    )
    )
  )

(defun mjljaa ()
  (setq all (+ all aa))
  (setq k (1+ k))
  )
(prompt"\n统计房屋面积<mj>")
(prin1)
(defun tj()
  (setq lay "A")
  (out)
  (setq lay "A2")
  (out)
  (setq lay "A3")
  (out)
  (setq lay "A4")
  (out)
  (setq lay "A5")
  (out)
  (setq lay "A6")
  (out)
  (setq lay "A7")
  (out)
  (setq lay "B")
  (out)
  (setq lay "B2")
  (out)
  (setq lay "B3")
  (out)
  (setq lay "B4")
  (out)
  (setq lay "B5")
  (out)
  (setq lay "B6")
  (out)
  (setq lay "B7")
  (out)
  (setq lay "B8")
  (out)
  (setq lay "B9")
  (out)
  (setq lay "C")
  (out)
  (setq lay "C2")
  (out)
  (setq lay "C3")
  (out)
  (setq lay "D")
  (out)
  (setq lay "D2")
  (out)
  )
(defun c:mj()
  (initget " tc bz tj")
  (setq mingl (getkword "预设图层(tc)，标注面积(bz),统计面积(tj):"))
  (cond ((= mingl "tc") (tc))
        ((= mingl "bz") (bz))
        ((= mingl "tj") (tj))
        )
  )

lxh410224

看看能用不

xiabin68

CASS自带的不就可以了吗?

lpl

lxh410224 发表于 2012-5-13 20:15
看看能用不

最好能演示下，我这边运行不了。

lxh410224

第一步：输入TC,有没有发现图层里面多了很多图层
第二步：输入BZ,先选择图层，A2房，就先选择A2层，在A2房内任处位置点击鼠标左键，如果数字标不出来，说明没有闭合。
第三步：输入TJ,根据图层来统计不同层数的建筑面积，注意是建筑面积，(一层占地X1，二层占地x2，类推）

Sean丶森

Andyhon 发表于 2012-5-10 09:45
练功坊:
http://www.google.com/search?as_epq=%E9%9D%A2%E7%A7%AF&as_oq=&as_eq=&as_nlo=&as_nhi=&lr=&cr ...

请大神帮忙修改下！

      1.点击某闭合区域生成多段线
      2.并在多段线内部标注面积与周长

小弟初来乍到没有币，还望大神海涵！不吝赐教！
谢啦!!☆⌒(*＾-゜)v

Sean丶森

Andyhon 发表于 2012-5-10 09:45
练功坊:
http://www.google.com/search?as_epq=%E9%9D%A2%E7%A7%AF&as_oq=&as_eq=&as_nlo=&as_nhi=&lr=&cr ...

；；*****************************************************************************************
(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:"))
   (defun maketext (txt pt)             ; 生成文字子函数
    (entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
   )
   (setvar "cmdecho" 0)
   (vl-load-com)
   (setq ss (ssget) ent (entlast))
   (command ".region" ss "")
   (setq ss (ssadd)  lst nil)
   (while (setq ent (entnext ent))
     (if (= (cdr (assoc 0 (entget ent))) "REGION")
       (setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
             m2 (rtos (vla-get-area obj) 2 2) d (rtos (vla-get-perimeter obj) 2 2) lst (cons (list pt m2 d) lst)
       )

     )
   )
   (command ".undo" "")
   (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
   (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
   (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))
   (write-line "编号\t周长(mm)\t面积(mm2)" f)
   (setq i 1)
   (foreach x lst
     (setq pt (car x) m2 (cadr x) d (caddr x))
     (maketext (strcat "A" (itoa i)) (list (car pt) (+ (cadr pt) 20)))
     (maketext (strcat "L=" d "mm") pt)
     (maketext (strcat "S=" m2 "mm2") (list (car pt) (- (cadr pt) 14)))
     (write-line (strcat (strcat "A" (itoa i)) "\t" d "\t" m2) f)
     (setq i (1+ i))
   )
   (close f)
   (princ)

趣意人生

收藏学习了！谢谢了