CADLISP程序.doc

1.计算所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度) (defun c:LL ()(setvar cmdecho 1)(setq en (ssget (list (0 . spline,arc,line,ellipse,LWPOLYLINE)(setq i 0)(setq ll 0)(repeat (sslength en) (setq ss (ssname en i) (setq endata (entget ss) (command lengthen ss ) (setq dd (getvar perimeter)(setq ll (+ dd ll) (setq i (1+ i) (princ 所选线条总长为：)(princ ll)(princ)2.标注所有线段(加载后只需框选所有线段便可得标注这些线段) (defun c:LLL ()(COMMAND UCS )(setvar cmdecho 1)(SETVAR OSMODE 0)(setq AcadObject (vlax-get-acad-object) AcadDocument (vla-get-ActiveDocument Acadobject) mSpace (vla-get-ModelSpace Acaddocument);选取需要测量的样条曲线、圆弧、直线、椭圆(setq en (ssget (list (0 . spline,arc,line,ellipse,LWPOLYLINE)(setq i 0);获取系统参数textsize(setq shh (getvar textsize)(setq str_hh (strcat n文字高度 : )(setq hh (getdist str_hh)(while hh(setvar textsize hh)(setq hh nil);输入标注文字高度;循环开始(repeat (sslength en) (setq ss (ssname en i) (setq endata (entget ss) (command lengthen ss ) (setq dd (getvar perimeter) (princ (strcat n长度= (rtos dd 2) ;寻找代表图层的字符串 (setq aa (assoc 0 endata) ;获取图层名称 (setq aa1 (cdr aa) ;判断线条种类 (cond (= aa1 SPLINE) ;如果是spline (progn (setq arcObj (VLAX-ENAME-VLA-OBJECT ss) (setq startPnt1 (vla-get-ControlPoints arcObj) (setq p1 (vlax-safearray-list (vlax-variant-value startPnt1) ) (setq x1 (car p1) (setq y1 (cadr p1) (setq z1 (caddr p1) (setq pp1 (list x1 y1 z1) (repeat (- (/ (length p1) 3) 1) ;循环，寻找最后一个控制点 (setq p1 (cdddr p1) (setq x2 (car p1) (setq y2 (cadr p1) (setq z2 (caddr p1) ) (setq pp2 (list x2 y2 z2) ) ) (= aa1 LWPOLYLINE) ;如果是LWPOLYLINE (progn (setq arcObj (VLAX-ENAME-VLA-OBJECT ss) (setq startPnt1 (vla-get-Coordinates arcObj) (setq p1 (vlax-safearray-list (vlax-variant-value startPnt1) ) (setq x1 (car p1) (setq y1 (cadr p1) (setq z1 (caddr p1) (setq pp1 (list x1 y1 z1) (repeat (- (/ (length p1) 3) 1) ;循环，寻找最后一个控制点 (setq p1 (cdddr p1) (setq x2 (car p1) (setq y2 (cadr p1) (setq z2 (caddr p1) ) (setq pp2 (list x2 y2 z2) ) ) (t ;如果是其他种类线条 (progn (setq arcObj (VLAX-ENAME-VLA-OBJECT ss) (setq startPnt1 (vla-get-StartPoint arcObj) ;获取起点 (setq endPnt1 (vla-get-EndPoint arcObj) ;获取终点 (setq pp1 (vlax-safearray-list (vlax-variant-value startPnt1) ) (setq pp2 (vlax-safearray-list (vlax-variant-value endPnt1) ) ) ) ) (setq x1 (car pp1) (setq y1 (cadr pp1) (setq z1 (caddr pp1) (setq x2 (car pp2) (setq y2 (cadr pp2) (setq z2 (caddr pp2) (setq x (/ (+ x1 x2) 2) (setq y (/ (+ y1 y2) 2) (setq z (/ (+ z1 z2) 2) (setq pt (list x y z) ;取得线段两端的中点 (setq ang (angle pp1 pp2) ;获取角度 (if ( (* (/ ang pi) 180) 180) (setq ang (+ ang pi) ) (command text j bc pt (* (/ ang pi) 180) (strcat (rtos dd 2) ) (setq i (1+ i)(prin1)(prompt n 在图中直接写出长度)(prin1)3.连续打断程序 (defun c:br1 () (command break pause f pause )4.将CAD文字导入Excel表格 (defun c:Q2()(setq ffn (getfiled 写出文件 xls 1)(princ n选取文字.)(setq ss (ssget)(setq ff (open ffn w)(setq i 0)(repeat (sslength ss)(setq ssn (ssname ss i)(setq ssdata (entget ssn)(setq sstyp (cdr (assoc 0 ssdata)(if (or (= sstyp TEXT) (= sstyp MTEXT)(progn(setq txt (cdr (assoc 1 ssdata)(princ txt ff)(princ n ff)(setq i (1+ i) )(close ff)(princ (strcat n写出文件: ffn)(prin1)5 删除带颜色图元以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次.改颜色的LISP程序(defun c:c1()(ssget)(command chprop p c 1 ) (princ)(defun c:c2()(ssget)(command chprop p c 2 ) (princ)(defun c:c3()(ssget)(command chprop p c 3 ) (princ)(defun c:c4()(ssget)(command chprop p c 4 ) (princ)(defun c:c5()(ssget)(command chprop p c 5 ) (princ)(defun c:c6()(ssget)(command chprop p c 6 ) (princ)(defun c:c7()(ssget)(command chprop p c 7 ) (princ)(defun c:c8()(ssget)(command chprop p c 8 ) (princ)你用C1 命令就可以将图元改为红色了.其余类似.删除红色图元(defun C:D1 (/ m A M) (setq m:err *error* *error* *merr*) (setvar cmdecho