[每日一码] 长度统计

nkmjg

1. ;;; ===============================================
2. ;;; 《长度统计》；如果选择变色的是取消选择，结果复制到剪切板
3. ;;; 作者：langjs
4. ;;; ===============================================
5. (defun c:cdtj (/ en ent html i len leng lst lst1 lwd n name name1 obj p result ss str)
6.   (defun #err (s / n)
7.     (foreach n lst  (entdel (cadr n)))
8.     (setvar "LWDISPLAY" lwd)
9.     (setvar "nomutt" 0)
10.     ((if command-s command-s vl-cmdf) ".UNDO" "E")
11.     (setq *error* $orr))
12.   (defun ssnext (en / ss)
13.     (setq ss (ssadd))
14.     (while (setq en (entnext en))
15.       (if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
16.         (setq ss (ssadd en ss)))) ss)
17.   (defun pd (name lst / n p)
18.     (setq p nil)
19.     (foreach n lst  (if (member name n) (setq p n))) p)
20.   (vl-load-com)
21.   (setvar "cmdecho" 0)
22.   (setq lwd (getvar "LWDISPLAY"))
23.   (vl-cmdf ".UNDO" "BE")
24.   (setvar "nomutt" 1)
25.   (setq $orr *error*  *error* #err  lst '()  leng 0.0)
26.   (princ "\n  选择对象：")
27.   (while (setq ss (setq ss (ssget ":S" '((0 . "LINE,CIRCLE,ARC,ELLIPSE,LWPOLYLINE,POLYLINE,SPLINE")))))
28.     (setvar "LWDISPLAY" 1)
29.     (setq lst1 '())
30.     (repeat (setq i (sslength ss))
31.       (setq lst1 (cons (ssname ss (setq i (1- i))) lst1)))
32.     (while (setq name (car lst1))
33.       (setq lst1 (cdr lst1)  obj (vlax-ename->vla-object name)
34.             len (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))  n (pd name lst))
35.       (if (setq n (pd name lst))
36.         (progn (setq lst (vl-remove n lst)  leng (- leng len)
37.                 lst1 (vl-remove (car n) lst1)  lst1 (vl-remove (cadr n) lst1))
38.           (entdel (cadr n)))
39.         (progn (setq ent (entget name)) (entmake (cdr ent))
40.           (setq name1 (entlast) lst (cons (list name name1) lst)
41.                 leng (+ leng len) obj (vlax-ename->vla-object name1) )
42.           (vla-put-color obj 60) (vla-put-lineweight obj aclnwt050))))
43.     (princ (strcat "\n  总长 = " (rtos leng) " mm"))
44.     (setq str (rtos leng)  html (vlax-create-object "htmlfile")
45.           result (vlax-invoke (vlax-get (vlax-get html 'parentwindow) 'clipboarddata) 'setdata "Text" str))
46.     (vlax-release-object html))
47.   (foreach n lst (entdel (cadr n)))
48.   (setvar "LWDISPLAY" lwd)
49.   (setvar "nomutt" 0)
50.   (vl-cmdf ".UNDO" "E")
51.   (setq *error* $orr)
52.   (princ)
53. )

复制代码