[每日一码] 面积统计
;; ===============================================;;; 《面积统计》，结果复制到剪切板
;;; 作者：langjs
;;; ===============================================
(defun c:mjtj (/ ar area e1 e2 en html i lst lst1 lwd n name obj pe perimeter pt result snap ss str)
(defun #err (s / i) ; 出错处理子函数
(repeat (setq i (length lst1))
(entdel (nth (setq i (1- i)) lst1 )))
(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)
(vl-load-com)
(setvar "cmdecho" 0)
(setq snap (getvar "osmode")lwd (getvar "LWDISPLAY"))
(setvar "osmode" 0)
(vl-cmdf ".UNDO" "BE")
(setq $orr *error**error* #errperimeter 0.0 area 0.0lst1 '())
(while (setq pt (getpoint (strcat "区域面积 = " (rtos area) " mm2 ,周长 = " (rtos perimeter) " mm")))
(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")
(progn
(setq obj (vlax-ename->vla-object name) pe (vla-get-perimeter obj) ar (vla-get-area obj))
(setq lst (cons (list ar pe) lst)))))
(setq lst (vl-sort lst (function (lambda (e1 e2) (> (car e1) (car e2))))))
(setq n (car lst) lst (cdr lst) perimeter (+ perimeter (cadr n)) area (+ area (car n)))
(while (setq n (car lst))
(setq lst (cdr lst) perimeter (+ perimeter (cadr n)) area (- area (car n))))
(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)
(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))
(setvar "LWDISPLAY" 1))
(repeat (setq i (length lst1))
(entdel (nth (setq i (1- i)) lst1)))
(setvar "LWDISPLAY" lwd)
(setvar "osmode" snap)
(vl-cmdf ".UNDO" "E")
(setq *error* $orr)
(princ)
)
页:
[1]