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文字高度<" (rtos shh 2) ">: ")) (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 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 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 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" 0)? ?? ?? ?? ? (command "UNDO" "G")? ?? ?? ?? ? (prompt "选择图形")? ?? ?? ?? ? (setq A (ssget '((62 . 1)) ))? ?? ?? ?? ? (if (/= A nil)(progn? ?? ?? ?? ? (setq M (sslength A))? ?? ?? ?? ? (command "erase" A "")? ?? ?? ?? ? (princ "\n共删除红色图元<")(princ M)(princ ">个") ? ?? ?? ?? ? ))? ?? ?? ?? ? (command "UNDO" "E")??? ?? ?? ?? ? (princ)??)??这样,键入D1 命令,就可以删除红色的图元了.。