在网上找的几个比较有用的lisp小程序

wangkewen

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 shh2) ">: "))

(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共删除红色图元<")(princM)(princ ">个")            

))            

(command"UNDO" "E")              

(princ)  

)

zhenz02

学习学习！多谢楼主！！

luhy2008

感谢分享!赞!

清风明月名字

谢谢楼主的分享！很有用啊！

ymcui

谢谢楼主的分享

donghuidong2003

谢谢楼主的热心

香田里浪人

请楼主测试一下，程序可运行否？比如4. 将CAD文字导入Excel表格
运行结果是：错误: no function definition: =SSTYP

yiqisese

确实比较实用

freehand8008

支持分享！！！！

wangkewen

香田里浪人 发表于 2014-4-19 12:46
请楼主测试一下，程序可运行否？比如4. 将CAD文字导入Excel表格
运行结果是：错误: no function definitio ...

测试过了，没有问题的，这个导出程序做的比较粗糙，只能讲文字导入到一列中，并且顺序有问题，明经上有高人写过了CAD导出到Excel的程序，不过没有源码，你看看吧http://bbs.mjtd.com/thread-93510-13-1.html

freehand8008

为什么啊？
2.      标注所有线段(加载后只需框选所有线段便可

命令: ap APPLOAD 已成功加载 LLL.LSP。
命令: ; 错误: 语法错误

香田里浪人

wangkewen 发表于 2014-4-23 08:54
测试过了，没有问题的，这个导出程序做的比较粗糙，只能讲文字导入到一列中，并且顺序有问题，明经上有高 ...

这个可能比你那个好用
;;;取得图层所有文本.
(defun c:outcsv()
(setq flnm (getfiled "保存文件名" "" "csv" 1))
　(setq fn (open flnm "w"))
　(setq s (ssget))
　(setq n (sslength s))
　(setq index ( - n 1))
　(repeat n
　　(setq ents (entget (ssname s index)))
　　(setq index ( - index 1))
　　(setq ent (assoc 0 ents))
　　(if ( = "TEXT" (cdr ent))
　　　　(progn
　　　　　　(setq txt (cdr (assoc 1 ents)))
　　　　　　(write-line txt fn)
　　　　)
　　)
　)
(close fn)
)
(princ "\n文本导出")