求多段线图形的面积 长度标注

limter

如何利用 list 列表命令得到面积及长度,并标注在图形上 也可以输出到EXCEL文件
下面是一段从网上得到的程序,不知如何修改
;;; AREAM.LSP
;;; Function: Calculates the total area of selected objects

(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)
)

香田里浪人

;;; 框选封闭区域面积到excel    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(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)

香田里浪人

论坛里有了，自己找。

664571221

香田里浪人 发表于 2013-1-20 20:51
;;; 框选封闭区域面积到excel    by:langjs
;;; ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
(defun c:qq (/ d ...

老师你这个怎么用不起来

香田里浪人

664571221 发表于 2015-12-21 11:25
老师你这个怎么用不起来

那就试试这个，应该可以用
;;;面积批量计算
(defun c:mjjs (/ ss j length1 m ent zbc i sum x y n2 cx cy x1 x2 p1 p3 p4 pt area)
   (setvar "cmdecho" 0)
(vl-load-com)
(setq TextHeight (getdist "\n请输入文字高度:(默认1)"))
    (if (= TextHeight nil) (setq TextHeight 1))
(while
  (setq ss (ssget (list (cons 0 "CIRCLE,LWPOLYLINE,ELLIPSE")))
length1 (- (sslength ss) 1)
j  0
  )
  (while (>= length1 0)
    (setq m   (ssname ss length1)
   ent (entget m)
   zbc '()
   i   1
   sum 0
   x   0
   y   0
     
    )
    (foreach n1 ent
      (if (= (nth 0 n1) 10)
(setq zbc (cons (cdr n1) zbc))
      )
    )
    (foreach n2 zbc
      (if (/= (rem i 2) 0)
(progn
   (setq x1 (nth 0 n2)
  y1 (nth 1 n2)
  i  (+ i 1)
   )
   (if (>= i 3)
     (progn
       (setq area (* (- (* x2 y1) (* x1 y2)) 0.500)
      sum  (+ sum area)
      cx (* (- (* x2 y1) (* x1 y2)) (+ x2 x1))
             cy   (* (- (* x2 y1) (* x1 y2)) (+ y1 y2))
      x (+ x cx)
      y (+ y cy)
       )
     )
   )
)
(progn
   (setq x2   (nth 0 n2)
  y2   (nth 1 n2)
  area (* (- (* x1 y2) (* x2 y1)) 0.500)
  sum  (+ sum area)
  cx   (* (- (* x1 y2) (* x2 y1)) (+ x2 x1))
  cy   (* (- (* x1 y2) (* x2 y1)) (+ y1 y2))
  i    (+ i 1)
  x    (+ x cx)
  y    (+ y cy)
   )

)
      )
    )
    (if (= (rem i 2) 0)
      (setq p1  (nth 0 zbc)
     x2  (nth 0 p1)
     y2  (nth 1 p1)
     area (* (- (* x1 y2) (* x2 y1)) 0.5)
     sum  (+ sum area)
     cx  (* (- (* x1 y2) (* x2 y1)) (+ x2 x1))
     cy  (* (- (* x1 y2) (* x2 y1)) (+ y1 y2))
     x  (+ x cx)
     y  (+ y cy)
      )
      (setq p1  (nth 0 zbc)
     x1  (nth 0 p1)
     y1  (nth 1 p1)
     area (* (- (* x2 y1) (* x1 y2)) 0.5)
     sum  (+ sum area)
     cx  (* (- (* x2 y1) (* x1 y2)) (+ x2 x1))
     cy  (* (- (* x2 y1) (* x1 y2)) (+ y1 y2))
     x  (+ x cx)
     y  (+ y cy)
      )
    )
    (setq x  (/ x (* sum 6))
   y  (/ y (* sum 6))
   pt (list  (- x 0.8) y)
          p1 (list  (+ x 0.8)  y)
    )
    (setq sum   (rtos (abs sum) 2 2)

   length1 (- length1 1)
                 p3 (list  x  (+ y 0.3))
                 p4 (list  x  (- y 0.3))
                 j (+ j 1)
               
    )
(setq sum (strcat "S=" sum  "㎡"))
(command "layer" "M" "面积" "C" "6" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
    (command "text" "j" "m" p3 TextHeight 0 sum)
      ))
)
;;;

dingtiedt

香田里浪人 发表于 2015-12-21 20:26
那就试试这个，应该可以用
;;;面积批量计算
(defun c:mjjs (/ ss j length1 m ent zbc i sum x y n2 cx ...

老师，这个对圆和椭圆没有反应。

知行ooo李肖坪

二楼，谢谢分享……