标注所有线段的lisp程序源码_在网上找的几个比较有用的lisp小程序

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 hhnil))

;;输入标注文字高度

;;循环开始

(repeat(sslength en)

(setq ss(ssname en i))

(setq endata(entget ss))

(command"lengthen" ss "")

(setq dd(getvar "perimeter"))

(princ(strcat "\n长度=" (rtos dd2)))

;;寻找代表图层的字符串

(setq aa(assoc 0 endata))

;;获取图层名称

(setq aa1(cdr aa))

;;判断线条种类

(cond    ((= aa1 "SPLINE")

;;如果是spline

(progn

(setq arcObj(VLAX-ENAME->VLA-OBJECT ss))

(setqstartPnt1 (vla-get-ControlPoints arcObj))

(setq p1

(vlax-safearray->list(vlax-variant-value startPnt1))

)

(setq x1 (carp1))

(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 (carp1))

(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))

(setqstartPnt1 (vla-get-Coordinates arcObj))

(setq p1

(vlax-safearray->list(vlax-variant-value startPnt1))

)

(setq x1 (carp1))

(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 (carp1))

(setq y2(cadr p1))

(setq z2(caddr p1))

)

(setq pp2(list x2 y2 z2))

)

)

(t

;;如果是其他种类线条

(progn

(setq arcObj(VLAX-ENAME->VLA-OBJECT ss))

(setqstartPnt1 (vla-get-StartPoint arcObj))

;;获取起点

(setq endPnt1(vla-get-EndPoint arcObj))

;;获取终点

(setqpp1       (vlax-safearray->list(vlax-variant-value startPnt1))

)

(setq

pp2(vlax-safearray->list (vlax-variant-value endPnt1))

)

)

)

)

(setq x1 (carpp1))

(setq y1(cadr pp1))

(setq z1(caddr pp1))

(setq x2 (carpp2))

(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"))

(prong

(setq txt(cdr (assoc 1 ssdata)))

(princ txtff)

(princ"\n" ff)))

(setq i (1+i))

)

(close ff)

(princ(strcat "\n写出文件: " ffn))

(prin1)

)

5.      删除带颜色图元

(defunc:c1()(ssget)(command "chprop" "p" """c" "1" "") (princ))

(defunc:c2()(ssget)(command "chprop" "p" """c" "2" "") (princ))

(defunc:c3()(ssget)(command "chprop" "p" """c" "3" "") (princ))

(defunc:c4()(ssget)(command "chprop" "p" """c" "4" "") (princ))

(defunc:c5()(ssget)(command "chprop" "p" """c" "5" "") (princ))

(defunc:c6()(ssget)(command "chprop" "p" """c" "6" "") (princ))

(defunc:c7()(ssget)(command "chprop" "p" """c" "7" "") (princ))

(defunc: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 (/= Anil)(progn

(setq M(sslength A))

(command"erase" A "")

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

))

(command"UNDO" "E")

(princ))