面积统计
本帖最后由 langjs 于 2024-2-29 14:21 编辑;;; ===============================================
;;;《面积统计》选择已选则为取消该选择，结果复制到剪切板
;;; 作者：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-scommand-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)
)
林立 发表于 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...
-----谢谢!!----- 谢谢大师分享，要是在能支持椭圆就更全面了 谢谢分享不错 收藏了，感谢分享 感谢分享,收藏了!!!!!!!!!!!!!!!!!!!! 谢谢大师分享！ 感谢大佬分享 动态识别面积区域，累积总面积计数，收藏！ 谢谢大佬分享。 不知道为何，总是卡死，那个长度统计就没有这种问题
页:
[1]
2