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' 0)

(command 'UNDO' 'G')

(prompt '选择图形')

(setq A (ssget '((62 . 1)) ))

(if (/= A nil)(progn

(setq M (sslength A))

(command 'erase' A '')

(princ '\n共删除红色图元个')

))

(command 'UNDO' 'E')

(princ) )

这样,键入 D1 命令,就可以删除红色的图元了.