[每日一码] 面积统计

nkmjg

1. ;; ===============================================
2. ;;; 《面积统计》，结果复制到剪切板
3. ;;; 作者：langjs
4. ;;; ===============================================
5. (defun c:mjtj (/ ar area e1 e2 en html i lst lst1 lwd n name obj pe perimeter pt result snap ss str)
6.   (defun #err (s / i)                  ; 出错处理子函数
7.     (repeat (setq i (length lst1))
8.       (entdel (nth (setq i (1- i)) lst1 )))
9.     (setvar "LWDISPLAY" lwd)
10.     (setvar "osmode" snap)
11.     ((if command-s command-s vl-cmdf) ".UNDO" "E")
12.     (setq *error* $orr))
13.   (defun ssnext (en / ss)
14.     (setq ss (ssadd))
15.     (while (setq en (entnext en))
16.       (if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
17.         (setq ss (ssadd en ss)))) ss)
18.   (vl-load-com)
19.   (setvar "cmdecho" 0)
20.   (setq snap (getvar "osmode")  lwd (getvar "LWDISPLAY"))
21.   (setvar "osmode" 0)
22.   (vl-cmdf ".UNDO" "BE")
23.   (setq $orr *error*  *error* #err  perimeter 0.0 area 0.0  lst1 '())
24.   (while (setq pt (getpoint (strcat "  区域面积 = " (rtos area) " mm2 ,  周长 = " (rtos perimeter) " mm")))
25.     (setq lst '() en (entlast) )
26.     (vl-cmdf "-boundary" "A" "I" "Y" "" pt "")
27.     (setq ss (ssnext en))
28.     (vl-cmdf ".region" ss "")
29.     (setq ss (ssnext en))
30.     (repeat (setq i (sslength ss))
31.       (setq name (ssname ss (setq i (1- i))))
32.       (if (= (cdr (assoc 0 (entget name))) "REGION")
33.         (progn
34.           (setq obj (vlax-ename->vla-object name) pe (vla-get-perimeter obj) ar (vla-get-area obj))
35.           (setq lst (cons (list ar pe) lst)))))
36.     (setq lst (vl-sort lst (function (lambda (e1 e2) (> (car e1) (car e2))))))
37.     (setq n (car lst) lst (cdr lst) perimeter (+ perimeter (cadr n)) area (+ area (car n)))
38.     (while (setq n (car lst))
39.       (setq lst (cdr lst) perimeter (+ perimeter (cadr n)) area (- area (car n))))      
40.     (setq str (rtos area) html (vlax-create-object "htmlfile")
41.           result (vlax-invoke (vlax-get (vlax-get html 'parentwindow) 'clipboarddata) 'setdata "Text" str))
42.     (vlax-release-object html)
43.     (vl-cmdf "explode" ss)
44.     (setq ss (ssnext en))
45.     (repeat (setq i (sslength ss))
46.       (setq name (ssname ss (setq i (1- i))) lst1 (cons name lst1) obj (vlax-ename->vla-object name))
47.       (vla-put-color obj 60)
48.       (vla-put-lineweight obj aclnwt050))
49.     (setvar "LWDISPLAY" 1))
50.   (repeat (setq i (length lst1))
51.     (entdel (nth (setq i (1- i)) lst1)))
52.   (setvar "LWDISPLAY" lwd)
53.   (setvar "osmode" snap)
54.   (vl-cmdf ".UNDO" "E")
55.   (setq *error* $orr)
56.   (princ)
57. )

复制代码