[每日一码] 长度统计
;;; ===============================================;;; 《长度统计》；如果选择变色的是取消选择，结果复制到剪切板
;;; 作者：langjs
;;; ===============================================
(defun c:cdtj (/ en ent html i len leng lst lst1 lwd n name name1 obj p result ss str)
(defun #err (s / n)
(foreach n lst(entdel (cadr n)))
(setvar "LWDISPLAY" lwd)
(setvar "nomutt" 0)
((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 pd (name lst / n p)
(setq p nil)
(foreach n lst(if (member name n) (setq p n))) p)
(vl-load-com)
(setvar "cmdecho" 0)
(setq lwd (getvar "LWDISPLAY"))
(vl-cmdf ".UNDO" "BE")
(setvar "nomutt" 1)
(setq $orr *error**error* #errlst '()leng 0.0)
(princ "\n选择对象：")
(while (setq ss (setq ss (ssget ":S" '((0 . "LINE,CIRCLE,ARC,ELLIPSE,LWPOLYLINE,POLYLINE,SPLINE")))))
(setvar "LWDISPLAY" 1)
(setq lst1 '())
(repeat (setq i (sslength ss))
(setq lst1 (cons (ssname ss (setq i (1- i))) lst1)))
(while (setq name (car lst1))
(setq lst1 (cdr lst1)obj (vlax-ename->vla-object name)
len (vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))n (pd name lst))
(if (setq n (pd name lst))
(progn (setq lst (vl-remove n lst)leng (- leng len)
lst1 (vl-remove (car n) lst1)lst1 (vl-remove (cadr n) lst1))
(entdel (cadr n)))
(progn (setq ent (entget name)) (entmake (cdr ent))
(setq name1 (entlast) lst (cons (list name name1) lst)
leng (+ leng len) obj (vlax-ename->vla-object name1) )
(vla-put-color obj 60) (vla-put-lineweight obj aclnwt050))))
(princ (strcat "\n总长 = " (rtos leng) " mm"))
(setq str (rtos leng)html (vlax-create-object "htmlfile")
result (vlax-invoke (vlax-get (vlax-get html 'parentwindow) 'clipboarddata) 'setdata "Text" str))
(vlax-release-object html))
(foreach n lst (entdel (cadr n)))
(setvar "LWDISPLAY" lwd)
(setvar "nomutt" 0)
(vl-cmdf ".UNDO" "E")
(setq *error* $orr)
(princ)
)
页:
[1]