面积统计

langjs

;;; ===============================================
;;;《面积统计》选择已选则为取消该选择，结果复制到剪切板
;;; 作者：langjs
;;; ===============================================

(defun c:mjtj (/ ar area centroid e1 e2 en html i lst lst1 lst2 lwd n name num obj pe perimeter principalmoments1 pt result s s1 snap
                 ss str )
  (defun #err (s / i n s1)               ; 出错处理子函数
    (foreach n lst2 (setq s (last n))(foreach n s (entdel n)))
    (setvar "lwdisplay" lwd)  (setvar "osmode" snap)
    ((if command-s  command-s vl-cmdf ) ".undo" "e" )
    (setq *error* $orr))
  (defun ssnext (en / ss)
    (setq ss (ssadd))
    (while (setq en (entnext en))
      (if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
        (setq ss (ssadd en ss)))) ss)               ; 四舍五入子函数
  (defun sswr (num n)
    (if (>= num 0.0)(/ (fix (+ (* num (expt 10.0 n)) 0.5)) (expt 10.0 n))(/ (fix (- (* num (expt 10.0 n)) 0.5)) (expt 10.0 n))))
  (vl-load-com)
  (setq $orr *error* *error* #err snap (getvar "osmode") lwd (getvar "LWDISPLAY") perimeter 0.0 area 0.0 lst2 '() )
  (setvar "cmdecho" 0) (setvar "osmode" 0)
  (vl-cmdf ".UNDO" "BE")
  (princ "\n 《面积统计》，如选择已选，则为取消该选择。结果复制到剪切表。")
  (while (setq pt (getpoint))
    (setq lst '() en (entlast))
    (vl-cmdf "-boundary" "A" "I" "Y" "" pt "") (setq ss (ssnext en))
    (vl-cmdf ".region" ss "") (setq ss (ssnext en))
    (repeat (setq i (sslength ss))
      (setq name (ssname ss (setq i (1- i))))
      (if (= (cdr (assoc 0 (entget name))) "REGION")
        (setq obj (vlax-ename->vla-object name) ar (sswr (vla-get-area obj) 4) pe (sswr (vla-get-perimeter obj) 4)
              principalmoments1 (sswr (car (vlax-safearray->list (vlax-variant-value (vla-get-principalmoments obj)))) 2)
              centroid (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
              centroid (list (sswr (car centroid) 2) (sswr (cadr centroid) 2))
              lst (cons (list ar pe centroid principalmoments1) lst))))
    (setq lst (vl-sort lst (function (lambda (e1 e2)  (> (car e1) (car e2)))))
          ar (car (car lst)) pe (cadr (car lst)) lst (cdr lst))
    (foreach n lst  (setq ar (- ar (car n)) pe (+ pe (cadr n))))
    (if (setq n (assoc (list ar pe centroid principalmoments1) lst2))
      (progn
        (setq perimeter (- perimeter pe) area (- area ar) lst2 (vl-remove n lst2) s (last n) ss (ssnext en))
        (repeat (setq i (sslength ss)) (entdel (ssname ss (setq i (1- i)))))
        (foreach n s (entdel n)))
      (progn
        (setq perimeter (+ perimeter pe)  area (+ area ar) lst1 '())
        (vl-cmdf "explode" ss) (setq ss (ssnext en))
        (repeat (setq i (sslength ss))
          (setq name (ssname ss (setq i (1- i))) lst1 (cons name lst1) obj (vlax-ename->vla-object name))
          (vla-put-color obj 60)  (vla-put-lineweight obj aclnwt050))
        (setq lst2 (cons (list (list ar pe centroid principalmoments1) lst1) lst2))))
    (princ (strcat "\n  区域面积 = " (rtos area) " mm2 ,  周长 = " (rtos perimeter) " mm"))
    (setq str (rtos area) html (vlax-create-object "htmlfile")
          result (vlax-invoke (vlax-get (vlax-get html 'parentwindow) 'clipboarddata) 'setdata "Text" str))
    (vlax-release-object html) (setvar "LWDISPLAY" 1))
  (foreach n lst2  (setq s (last n))
    (foreach n s (entdel n) ))
  (setvar "LWDISPLAY" lwd)
  (setvar "osmode" snap)
  (vl-cmdf ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

huxu823

林立 发表于 2024-5-20 10:32
大佬，单位改成米和平方，会好用

;(princ (strcat "\n  区域面积 = " (rtos area) " mm2 ,  周长 = " (rtos perimeter) " mm"))
(princ (strcat "\n  区域面积 = " (rtos (/ area 1000000)) " m2 ,  周长 = " (rtos (/ perimeter 1000)) " m"))

林立

huxu823 发表于 2024-5-20 11:04
;(princ (strcat "\n  区域面积 = " (rtos area) " mm2 ,  周长 = " (rtos perimeter) " mm"))
(princ  ...

-----谢谢!!-----

sowin

谢谢大师分享，要是在能支持椭圆就更全面了

wangsr

谢谢分享不错

shirker

收藏了，感谢分享

yoyoho

感谢分享,收藏了!!!!!!!!!!!!!!!!!!!!

panliang9

谢谢大师分享！

magicheno

感谢大佬分享

jkop

动态识别面积区域，累积总面积计数，收藏！

Noangler

谢谢大佬分享。

huxu823

不知道为何，总是卡死，那个长度统计就没有这种问题