CAD LISP 程序
LISP经典程序
;；一、绘制地形图符号1.点状符号对于点状符号，其位置固定，数量较多，且一般都带有一定的标注,可逐个制作属性块图元，单独插入.2。
线状符号利用AutoCAD中强大的线型定义.3.面状符号由充填符号在面域内按一定的排列方式组合而成。
目前Auto CAD在建筑设计、工程施工放样得到广泛应用，Auto CAD在工程测量上的应用，大大减少手算坐标的工程量或帮助人们复核手算坐标的准确性。
(1）删除未选择对象（defun c：sd(）（princ"\n选择要保留对象："）(setq SS（ssget) ss1(ssget”X"）)（command”erase"ss1"r”ss"”zoom _e））；end;;(2）画圆弧型铁路；输入铁路中线上三个点，轨距及绘图比例尺,起、中、始点（defun c：ytl（）(setvar ”osmode" 0)；取消扑捉(setq PB(getpoint"\n输入起点："）)（setq PM(getpoint”\n输入中点：”）)（setq PE（getpoint"\n输入终点:”))(setq WD(getreal”\n输入铁路宽度(m）：")）(setq S(getreal”\n绘图比例尺=:"）)；1:1000,输入1。
0(setq W1(/(＊WD S) 2) W2（+ W1（＊0。
6 S))）;轨道及枕木符号的半宽（setq D(distance PB PE)）（setq A1（angle PB PM）A2（angle PB PE) A3（angle PE PB) A4(angle PE PM））(setq FB（— A1 A2) FE（— A3 A4) P12（* PI 2))（if (〈FB 0）（setq FB（+ FB P12）));求PB和PE点的圆周角(if （〈FE 0)（setq FE（+ FE P12))）(setq F(+ FB FE）R（/ D（＊（sin F)2)));求全弧所对圆心角之半，圆弧半径(setq F1（- (/ PI 2) F) ABC（— A2 F1））(if （〈ABC 0）(setq ABC(+ ABC P12))）（setq C（polar PB ABC R））；求圆心之点位(setq ACB（angle C PB) ABC（angle PB C)）;起点左右垂直于中线切线的方位角（setq ACM(angle C PM）AMC(angle PM C))；中点左右垂直于中线切线的方位角（setq ACE（angle C PE）AEC(angle PE C））;终点左右垂直于中线切线的方位角（setq PBL（polar PB ACB W1) PBL1(polar PB ACB W2）)（setq PBR（polar PB ABC W1）PBR1(polar PB ABC W2)）（setq PML（polar PM ACM W1) PMR(polar PM AMC W1）)（setq PEL（polar PE ACE W1）PER（polar PE AEC W1）)（setq S2(* 0。
CAD LISP 程序教学内容
C AD L I S P程序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 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)))(setqpp2 (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共删除红色图元<")(princ M)(princ ">个") ))(command "UNDO" "E")(princ) )这样,键入 D1 命令,就可以删除红色的图元了.。
CAD中自动画管线图的LISP程序
(defun c:brel(/myosmode horv p p1 p2 p3)
(setq myosmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq p (getpoint "\nSelect point to break:"))
(initget 1P程序
画一些管路原理图时，当代表不同管路的直线在图中相交时，需将在交点处的某一直线断开，再用一半圆连接两断点，使用下面这个LISP编写的程序，只用键入"brel"的命令，其它的就由电脑去完成了。
程序中使用"break"命令截断需要被断开的管线，再用"arc"命令画一半圆连接两断点。变量p读取管线交点；p1、p2为点p的左右或上下两点；p3为连接p1、p2半圆的中点。由于使用"break"命令时若AUTOCAD环境处于对象捕捉方式（OSMODE≠0），则"break"命令截断的p1、p2两点可能为变为p1、p2附近的捕捉点。所以程序开始时用变量myosmode记录系统变量OSMODE，而后设置OSMODE为0，程序结束后再设置还原OSMODE。变量horn判断用户需要断开的是水平线还是垂直线。
(setq p3 (list (car p) (+ (cadr p) 1.5)))
)
(progn
(setq p1 (list (car p) (- (cadr p) 1.5)))
(setq p2 (list (car p) (+ (cadr p) 1.5)))
(setq p3 (list (+ (car p) 1.5) (cadr p)))
CAD画渐开线lisp程序
) ;(princ (> p ja)) ;(princ (= p ja)) ;(princ (< p ja))
)
;(redraw) ;对象捕捉 (setvar "osmode" dx) ;控制undo (if (/= ud 0)
(command "undo" "e") )
)
第三步：将文档名称改为“渐开线.lsp”，注意，文件后缀同时由“.txt” 改为“.lsp”。 （如果，你的电脑不显示文件后缀，请先做如下设置，去掉对钩）
* 适用于Auto CAD各版本，适用于室内装潢、机械设计等
输入命令：jkx
鼠标选取或输入圆心 位置
输入基圆半径
输入基圆半径
输入角度
第一步：在桌面建立一个文本文档
第二步：打开文档，将以下lisp代码复制到文档内，并保存关闭
(defun c:jkx(/ jo jr ja p ls p2 x y ud dx) (graphscr) (setvar "cmdecho" 0) ;(setvar "comdecho" 0) (setq jo(getpoint"\n请输入圆心位置:")) (setq jr(getdist"\n请输入基圆半径:")) (setq ja(getreal"\n请输入渐开线(10进制)角度:")) (setq p 0) (setq ls (list (+ jr (car jo)) (cadr jo))) ;控制undo (if (/=(getvar "undoctl") 0) (command "undo" "be") (setq ud 0) ) ;对象捕捉 (setq dx (getvar "osmode")) (setvar "osmode" 0) ;(command "pline" ) (while (<= p (- ja 0.5)) (setq p (+ 0.5 p)) (setq p2 (* (/ p 180) pi)) (setq x (+ (car jo) (+ (* jr (cos p2)) (* pi jr (/ p 180) (cos (- p2 (/ pi 2))))))) (setq y (+ (cadr jo) (+ (* jr (sin p2)) (* pi jr (/ p 180) (sin (- p2 (/ pi 2))))))) ;(command "point" (list x y))
CADLISP程序
1.计算所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度)(d e f u n c:L L() (s e t v a r"c m d e c h o"1) (setq en (ssge t(list '(0 . "spline,a rc,line,ellipse,LW POLYLIN E")))) (s e t q i0) (s e t q l l0) (r e p e a t(s s l e n g t h e n) (s e t q s s(s s n a m e e n i)) (s e t q e n d a t a(e n t g e t s s))(c o m m a n d"l e n g t h e n"s s"")(s e t q d d(g e t v a r"p e r i m e t e r")) (s e t q l l(+d d l l)) (s e t q i(1+i)))(p r i n c"所选线条总长为：")(p r i n c l l)(p r i n c))2.标注所有线段(加载后只需框选所有线段便可得标注这些线段)(d e f u n c:L L L() (C O M M A N D"U C S""") (s e t v a r"c m d e c h o"1) (S E T V A R"O S M O D E"0) (s e t q A c a d O b j e c t(v l a x-g e t-a c a d-o b j e c t)A c a d D o c u m e n t(v l a-g e t-A c t i v e D o c u m e n t A c a d o b j e c t)m S p a c e(v l a-g e t-M o d e l S p a c e A c a d d o c u m e n t));;选取需要测量的样条曲线、圆弧、直线、椭圆(setq en (ssge t(list '(0 . "spline,a rc,line,ellipse,LW POLYLIN E")))) (s e t q i0) ;;获取系统参数t e x t s i z e (s e t q s h h(g e t v a r"t e x t s i z e")) (s e t q s t r_h h(s t r c a t"\n文字高度<"(r t o s s h h2)">:"))(s e t q h h(g e t d i s t s t r_h h)) (w h i l e h h (s e t v a r"t e x t s i z e"h h) (s e t q h h n i l)) ;;输入标注文字高度;;循环开始(r e p e a t(s s l e n g t h e n) (s e t q s s(s s n a m e e n i)) (s e t q e n d a t a(e n t g e t s s))(c o m m a n d"l e n g t h e n"s s"")(s e t q d d(g e t v a r"p e r i m e t e r")) (p r i n c(s t r c a t"\n长度="(r t o s d d2))) ;;寻找代表图层的字符串(s e t q a a(a s s o c0e n d a t a)) ;;获取图层名称(s e t q a a1(c d r a a));;判断线条种类(c o n d((=a a1"S P L I N E") ;;如果是s p l i n e(p r o g n (s e t q a r c O b j(V L A X-E N A M E->V L A-O B J E C T s s)) (s e t q s t a r t P n t1(v l a-g e t-C o n t r o l P o i n t s a r c O b j))(s e t q p 1 (v l a x-s a f e a r r a y->l i s t(v l a x-v a r i a n t-v a l u e s t a r t P n t1))) (s e t q x1(c a r p1))(s e t q y1(c a d r p1)) (s e t q z1(c a d d r p1)) (s e t q p p1(l i s t x1y1z1)) (r e p e a t(-(/(l e n g t h p1)3)1) ;;循环，寻找最后一个控制点(s e t q x2(c a r p1))(s e t q y2(c a d r p1))(s e t q z2(c a d d r p1))) (s e t q p p2(l i s t x2y2z2)))) ((=a a1"L W P O L Y L I N E") ;;如果是L W P O L Y L I N E(p r o g n (s e t q a r c O b j(V L A X-E N A M E->V L A-O B J E C T s s)) (s e t q s t a r t P n t1(v l a-g e t-C o o r d i n a t e s a r c O b j)) (s e t q p 1 (v l a x-s a f e a r r a y->l i s t(v l a x-v a r i a n t-v a l u e s t a r t P n t1)))(s e t q y1(c a d r p1)) (s e t q z1(c a d d r p1)) (s e t q p p1(l i s t x1y1z1)) (r e p e a t(-(/(l e n g t h p1)3)1) ;;循环，寻找最后一个控制点(s e t q p1(c d d d r p1))(s e t q x2(c a r p1))(s e t q y2(c a d r p1))(s e t q z2(c a d d r p1))) (s e t q p p2(l i s t x2y2z2))))(t ;;如果是其他种类线条(p r o g n (s e t q a r c O b j(V L A X-E N A M E->V L A-O B J E C T s s)) (s e t q s t a r t P n t1(v l a-g e t-S t a r t P o i n t a r c O b j));;获取起点(s e t q e n d P n t1(v l a-g e t-E n d P o i n t a r c O b j));;获取终点(s e t q p p 1 (v l a x-s a f e a r r a y->l i s t(v l a x-v a r i a n t-v a l u e s t a r t P n t1)))(s e t q p p2(v l a x-s a f e a r r a y->l i s t(v l a x-v a r i a n t-v a l u e e n d P n t1)))))) (s e t q x1(c a r p p1))(s e t q y1(c a d r p p1)) (s e t q z1(c a d d r p p1)) (s e t q x2(c a r p p2)) (s e t q y2(c a d r p p2)) (s e t q z2(c a d d r p p2)) (s e t q x(/(+x1x2)2)) (s e t q y(/(+y1y2)2)) (s e t q z(/(+z1z2)2)) (s e t q p t(l i s t x y z)) ;;取得线段两端的中点(s e t q a n g(a n g l e p p1p p2)) ;;获取角度(i f(>(*(/a n g p i)180)180)(s e t q a n g(+a n g p i)))(c o m m a n d"t e x t""j""b c"p t""(*(/a n g p i)180) (s t r c a t""(r t o s d d2))"") (s e t q i(1+i)))(p r i n1))(p r o m p t"\n<>在图中直接写出长度") (p r i n1)3.连续打断程序(d e f u n c:b r1()(c o m m a n d"b r e a k"p a u s e"f"p a u s e"@"))4.将C A D文字导入E x c e l表格(d e f u n c:Q2() (s e t q f f n(g e t f i l e d"写出文件""""x l s"1)) (p r i n c"\n选取文字...") (s e t q s s(s s g e t)) (s e t q f f(o p e n f f n"w")) (s e t q i0) (r e p e a t(s s l e n g t h s s) (s e t q s s n(s s n a m e s s i)) (s e t q s s d a t a(e n t g e t s s n)) (s e t q s s t y p(c d r(a s s o c0s s d a t a))) (i f(o r(=s s t y p"T E X T")(=s s t y p"M T E X T"))(p r o g n (s e t q t x t(c d r(a s s o c1s s d a t a))) (p r i n c t x t f f) (p r i n c"\n"f f)))(s e t q i(1+i)))(c l o s e f f) (p r i n c(s t r c a t"\n写出文件:"f f n)) (p r i n1) )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 命令,就可以删除红色的图元了.。
超经典CAD_lisp程序集锦、CAD快捷键大全
超经典CAD lisp程序集锦如果您使用 AutoCAD,下面的内容对您一定有帮助。
在某些方面能大大提高您的工作效率。
下面的程序均以源程序方式给出，您可以使用、参考、修改它。
bg.lsp --- 表格自动生成asc.lsp --- 将文本文件内容写入图中，字符是单个的wf.lsp --- 将图中字符写入磁盘exstr.lsp --- 将字符串分解成单字pgtxt.lsp --- 将字符合成字符串pb.lsp --- 通过给出长度将字符串分成两个串cht.lsp --- 直接修改文字内容或块属性ct.lsp --- 对数字串进行加减chh.lsp --- 直接修改文字高度chhw.lsp --- 直接修改文字高宽比(针对PKPM软件将字符定位点改为左下角) chst.lsp --- 直接修改文字字体txt.shx --- 修改后的标准txt.shx文件。
(kuozhan.sld为增强的内容幻灯片)tiao.lsp --- 配合修改过的标准字体文件，将中文字符调大tiao1.lsp --- 配合修改过的标准字体文件，将英文字符调小untiao.lsp --- 上两个程序的复原sht.lsp --- 在图中查找字符串zhuang.lsp --- 桩点及钎探号绘制（勘测图）dim.lsp --- 配合JT.DWG将尺寸标注调成适合建筑结构设计(1:1)dimm.lsp --- 配合JT.DWG将尺寸标注调成适合建筑结构设计(1:100)di1.lsp～di8.lsp --- 直接连续标注尺寸(用于1:1的图)di100.lsp～di800.lsp --- 直接连续标注尺寸(用于1:100的图)详细内容及附件下载请浏览北纬服务论坛/thread-2724-1-1.html该程序实现的功能如图中所示，只要选择矩形，便可将穿过矩形的直线剪切（以前是一条一条的选择），由于水平有限，程序的语句可能太繁琐，但功能对我面言很实用（以前我下载了一个，但效果不好，连矩形外也剪掉了），请各位高手优化！源程序如下：代码:p1 (car l1)) (command "erase" e0 "") (setq count 0) (repeat 3 (setq count (+ count 1)) (setq pt (nth count l1)) (command "trim" rect "" "f" p1 pt """") ) (setq p1 (cadr l1)) (command "erase" e0 "") (setq count 1) (repeat 2 (setq count (+ count 1)) (setq pt (nth count l1)) (command "trim" rect "" "f" p1 pt """") ) (setvar "osmode" 687))你的程序在实际使用中，有时将矩形的边或矩形外的线剪切掉了，我的程序参照你的程序重新编了一下，不好意思，借用了你的思路.(朋友多，互相学习)有些语句实际上重复了，昨天我又改了下，源程序如下：(defun c:mytrim(/ rect e0 e1 pt x ptx pty l1 i p1 p2 p1x p1y point count)(setvar "osmode" 0)(setq l1 nil)(setq i 0)(setq rect (car (entsel "\n请选择需剪切的矩形:")))(setq e0 (entget rect))(while (setq x (nth i e0))(if(= (car x) 10)(progn(setq ptx (nth 1 x))(setq pty (nth 2 x))(setq x (list ptx pty))(setq l1 (cons x l1))))(setq i (1+ i)))(reverse l1)(setq p1 (car l1))(setq p1x (nth 0 p1))(setq p1y (nth 1 p1))(setq count 0)(repeat 3(setq count (+ count 1))(setq pt (nth count l1))(setq ptx (nth 0 pt))(setq pty (nth 1 pt))(setq point (mapcar '+ p1 pt))(setq point (mapcar '/ point '(2.0 2.0 2.0))) (if(and (/= (nth 0 point) p1x)(/= (nth 0 point) ptx)(/= (nth 1 point) p1y)(/= (nth 1 point) pty))(setq p point)))(setq l1 nil)(command "offset" 5 rect p "")(setq e0 (entlast))(setq e1 (entget e0))(princ e1)(setq i 0)(while (setq x (nth i e1))(if(= (car x) 10)(progn(setq ptx (nth 1 x))(setq pty (nth 2 x))(setq x (list ptx pty))(setq l1 (cons x l1))))(setq i (1+ i)))(reverse l1)(setq p1 (car l1))(setq p2 p1)(command "erase" e0 "")(setq count 0)(repeat 3(setq count (+ count 1))(setq pt (nth count l1)) (command "trim" rect "" "f" p1 pt "" "") (setq p1 pt))(command "trim" rect "" "f" p1 p2 "" "")(setvar "osmode" 687))画箍筋的lisp程序画剪力墙暗柱很实用。
五个实用的AutoCAD的lisp程序
五个实用的AutoCAD的lisp程序1、计算CAD图形中所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度)(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、标注CAD图形中所有线段(加载后只需框选所有线段便可得标注这些线段)(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 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)))(setqpp2 (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、删除带颜色图元以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次。
CAD中LISP程序使用方法
CAD中LISP程序使用方法2007-08-06 19:13:32| 分类：学习园地 |字号订阅1. 对于提供附件下载的，把附件下载就可以了2. 对于提供的源LISP代码，把代码拷贝、粘贴到一个文件，自己起个名或者若程序里面注释推荐了文件名，就用推荐的，然后保存成扩展名是LSP的文件即可了。
LISP程序使用方法：加载LISP1. 可以使用APPLOAD命令，然后去找到要加载的LISP文件，加载即可。
2. 可以自己从文件管理器把LISP文件拖动到ACAD的图形窗口，也可以加载3. 在命令行后用，(load "c:\\temp\\xxx.lsp")也可以加载，路径名请输入实际的路径。
另：对于一个LSP程序，(defun 后面的既是命令或者函数，一般程序应该有提示，若没有，标志符c:后面的单词是可以在ACAD下使用的命令，既可以在COMMAND:后面直接输入，即可执行。
CAD快速切换图层LISP代码（方法2）给楼主发一个图层更改的lisp程序，按对应数字键就可以切换到相应的图层。
很方便。
0————01————OBJ2————6t3————SCETR。
8————BORDER如果这些不是你想要的图层，将lisp用笔记本打开，把里边的OBJ，6t等图层名改为你想要的就可以了。
以后要切换图层时，按相应的数字键即可。
(defun YH_chlayer (YH_layer / YH_S)(if (null (tblsearch "LAYER" YH_layer))(entmake (list'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")(cons 2 YH_layer) ;图层名称'(70 . 0) ;图层状态'(62 . 7) ;图层颜色'(6 . "bylayer") ;图层线型)))(setq YH_S (cadr (ssgetfirst)))(if YH_S(command "CHPROP" YH_S "" "la" YH_layer "c" "bylayer" "")(setvar "clayer" YH_layer))(princ))(defun c:0 ()(YH_chlayer "0"))(defun c:1 ()(YH_chlayer "OBJ"))(defun c:2 ()(YH_chlayer "6t"))(defun c:3 ()(YH_chlayer "SCETR"))(defun c:4 ()(YH_chlayer "HIDD"))(defun c:5 ()(YH_chlayer "DIM"))(defun c:6 ()(YH_chlayer "DASH"))(defun c:7 ()(YH_chlayer "TEXT"))(defun c:8 ()(YH_chlayer "BORDER"))#Cad到上面一行为址，保存为lsp格式。
CADLISP程序
1.计算所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度)(defun c:LL ())om1d(sevteacr h c(setq en (ssge t (list '(0 .spline,arc,line,ellipse,LWPOLYLINE))))(setq i 0)) q l0(setl) (selshter(n epeant g)( m)stsq nesse i(anse (setq endata (entget ss)))(command le ngthen ss(setq dd (getvar perimeter))(setq ll (+ dd ll))))(siet q+ i1())为总线所nr( pic选条长：)(ll nir(pc)irpnc)2.标注所有线段(加载后只需框选所有线段便可得标注这些线段) (defun c:LLL ()) SND (UCOMCMA) hcet vmcadr (os1e)DVO AMSORETS 0E((setq AcadObject (vlax-get-acad-object) AcadDocument (vla-get-ActiveDocument Acadobject)mSpace (vla-get-ModelSpace Acaddocument));;选取需要测量的样条曲线、圆弧、直线、椭圆(setq en (ssge t (list '(0 . spline,arc,line,ellipse,LWPOLYLINE))))(setq i 0)estez;;获取x系t统参数i(setq shh (getvar textsize))(setq str_hh (strcat \n文字高度)) :> )2 hhs sotr( <(setq hh (getdist str_hh))hh lwe(ihsetvar t(extsize hh)) e t)qhi(s nlh度字注入;;输标高文环循;;开始ngth enrepeat (ssle())s)s (s est(ameq e nnis (setq endata (entget ss)))(command lengthen s s(setq dd (getvar perimeter))(princ (strcat \n长度= (rtos dd 2)))表代图; ;寻找层的字符串(setq (assoc aa endata)) 0层名获;图称取;rd))aa c( 1aaes( qt;;判断线条种类dn( ocENaa1) S (LPI(=i 如n是;果sp;e lgorp (n(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))(setq startPnt1 (vla-get-ControlPoints arcObj))(setq p1(vlax-safearray->list (vlax-variant-value startPnt1)) )) )pr x(1 ca1q( set) y1r (q1 cpad s(e)t)1zar1pq d ( (dstec)(setq p p1 (list x1 y1 z1)) (repeat (- (/ (length p1) 3) 1);;循环，寻找最后一个控制点(setq p1 (cdddr p1))) ((sc1ea tqr) x2p) 1 ca y)(s2p etdr q (r1 )z 2dc aqs( p ) e td()(setq pp2 (list x2 y2 z2))))((= aa1 LWPOLYLINE)LWPO L Y果是L;;INE 如n(g rpo(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))) c s( eat1qd yp1r ) ()a()sd1ert1 qd( c zp(setq pp1 (lis t x1 y1 z1))(repeat (- (/ (length p1) 3) 1);;循环，寻找最后一个控制点)) pq 1ddcdpr ( 1 e(stpt q) c) a1x 2 s( e ( r1 yp) r2((desact q)1p) 2(s) ectdqd (az r))pp2 qes(ts il(t2x 2yz 2)))t (条种是如;;果他其类线(progn(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))(setq startPnt1 (vla-get-StartPoint arcObj));;获取起点(setq endPnt1 (vla-get-EndPoint arcObj));;获取终点1tp q p( se (vlax-safearray->list (vlax-variant-value startPnt1)) )qe( s t pp2 (vlax-safearray->list (vlax-variant-value endPnt1)) ))))))1pp rac( 1x qtes((setq y1 (cadr pp1))) d (pstedpq rz1) (c1a) pa()s2re p qt2( cx) )2 2a( spredy(tq cpp zrd p2c(q s2) et) ad((setq x (/ (+ x1 x2) 2))2) y1 ) (/q(set y y2)(+(z2z1 ) 2) (+) q e(st/ ztzxtiest( q l spy )) (线;两的取中;段得端点(set q ang (angle pp1 pp2))角取度;;获(if (> (* (/ ang pi) 180) 180)(setq ang (+ ang pi)))txet dnammoc(jb cpt180)ia (*(/ng p)) 2)tt (srcao (rts dd)))+(1qe(st ii))pr(in1))度长出写rp(< \ pmotn接中图在>直)inr(p1连.断3打续程序(defun c:br1 ()(command break pause f pause @))4.将CAD文字导入Excel表格)d:e( f2u(cnQ(setq ffn (getfiled 写出文件xls 1))(princ \n选取文字...)) (stss)es(gtqs e) oe nw fff (fpnsqe(t)) q(s 0eti) ssha gt( eelr(epnsst) e si n(q namss)sstes(s)q se)tensd ( tgatsasnt(es(setq sstyp (cdr (assoc 0 ssdata)))))TXETM pytss =( )TXET pytss =( ro( fi((progn(setq txt (cdr (assoc 1 ssdata)))(princ txt ff)ffc \n)(prin))1i (+ i)) s(etq))sfe fc(lo)n)件f :f文写\ ars nr(pic(tctn出) nrpi1( )5删除带颜色图元.以下程序在别人的贴子里贴过为了说明问题.,今天再贴一次LISP改颜色的程序(defun c:c1()(ssget)(command chprop p \ c \) (princ))(defun c:c2()(ssget)(command chprop p \ c \) (princ))(defun c:c3()(ssget)(command chprop p \ c \) (princ)) (defun c:c4()(ssget)(command chprop p \ c\) (princ))(defun c:c5()(ssget)(command chprop p \ c _x0005_ \) (princ))(defun c:c6()(ssget)(command chprop p \ c \) (princ))(defun c:c7()(ssget)(command chprop p \ c _x0007_ \) (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)瀨潲灭?选择图形)(setq A (ssget '((62 . 1)) ))(if (/= A nil)(progn(setq M (sslength A))(command erase A \)(princ \共删除红色图元<)(princ M)(princ >个)))(command UNDO E)(princ) ).就可以删除红色的图元了,命令D1 键入,这样．。
AUTOCAD中的几个LISP程序
AUTOCAD中的几个LISP程序李敬--------------------------------------------------------------------------------机械制图中，常常得做许多大量的重复工作。
下面这几个用Lisp编写得程序，是我画图时经常使用的，节省了我的不少时间，希望也能帮助广大使用AUTOCAD的工程师们。
1.自动求和机械制图中材料表的填写是毕不可少的，填写完后还需根据材料表求出总重量。
一般一幅图中常有几十个物体，将这些重量一项一项相加个繁琐的过程，而且容易出错。
使用下面这个程序，只需用鼠标选定需要相加的数，其和就会自动的显示在命令行中。
因为在AUTOCAD中没有“数”这种实体，所有的数都以实体“TEXT”存在，所以程序中使用了“atof”函数，将以字符串形式表示的数转换为实数。
(defun c:total( / cmdmode sset ssl nsset temp ssl1 total)(if *error* quit)(setq cmdmode (getvar "cmdecho"))(setvar "cmdecho" 0)(prompt "\nSelect numbers to add: ")(setq sset (ssget))(if (null sset)(princ "\nError: Nothing selected!\n");过滤出选中的“text”实体，并报告有多少“text”实体被选中。
(progn(setq ssl (sslength sset))(setq nsset (ssadd))(while (> ssl 0)(setq temp (ssname sset (setq ssl(1- ssl))))(if (= (cdr (assoc 0 (entget temp))) "TEXT")(ssadd temp nsset)))(setq ssl (sslength nsset))(print ssl)(princ "text entities are found.");选出所有可转化为数的“TEXT”，并求和。
CAD中添加LISP
CAD技巧：中望CAD中加载LISP程序1、首先请加载lisp程序，加载方法如下：在菜单栏选择工具——加载应用程序——添加，选择lisp程序然后加载，然后选择添加到启动组。
(其他lisp使加载方式相同)2、然后是添加自定义栏以及图标，方法如下（以坐标标注为例，其余操作相同）：在软件右上方空白区右键选择自定义——工具栏——新建——（修改名称）确定（以下操作均是在不关闭自定义前提下的操作）。
此时在左侧图层工具栏下面会出现一个空白工具栏，然后在命令里面，随便找一个图标（例如新建、打开等等以下以新建为例）拖放入新建的空白工具栏里，右键点击拖放在空白工具栏里的图标，选修改。
在弹出对话框里有名称、命令、说明三项可以修改。
其中将命令“^C^C_new”修改为“^C^C_zbbz”，将名称修改为“坐标标注”，然后确定。
再次右键点击此图标，选择编辑按钮图像，工具一栏最后一个命令图标Import From File。
选择坐标标注所对应的图标打开然后确定。
3、在使用了自定义工具栏后可能需要将这些工具栏导出给其他同事使用，这是就需要将工具栏导出，导出和导入方法如下：导出:在自定义完工具栏后，选择工具——自定义——工具栏然后导出，在选项框里将刚才自定义的勾选，其他象不选择，否则会出现重复，然后确定，选择XML工具条文件（xml）格式保存。
导入：加载工具栏文件：选择工具——自定义——工具栏，选择导入，文件类型选择XML工具条文件（xml），选择然后打开。
要注意的地方是：其他命令操作与以上相用，所加载的lisp程序与图片所在文件夹为固定文件夹，不可修改，否则不能调用其命令，加载lisp程序后一定要选择“添加到启动组”，否则软件启动后不能自己加载此lisp程序。
以上是在中望 CAD中加载LISP程序的具体挂接方法，除开LISP，中望 CAD还提供了VBA、SDS以及DRX（类ARX）接口，用户可以针对自己的使用要求，优化、改善软件使用功能、方式，中望CAD2009的推出，让中望 CAD的扩展接口特别是DRX接口更加完善，并已成功应用到与天河软件、清华斯维尔建筑、鸿业暖通给排水等二次开发的合作中去。
CAD画缓和曲线lisp程序
CAD中画缓和曲线，首先复制本文☆后面的源程序保存至cad安装目录的SUPPORT文件夹，保存类型为.lsp 可以随便复制一个SUPPORT文件夹内的lsp文件，然后替换本文的程序。
打开CAD后，输入appload回车，找到你保存的缓和曲线lsp程序，点击加载，然后就可以画缓和曲线了。
首先，要画出缓和曲线的两条直线，然后输入HH回车，按提示完成缓和曲线。
注：本程序，缓和曲线段拟合长度为0.4m，如需更改拟合长度，将程序的第8行(repeat (FIX(/ Ls 0.4))及9行(setq l (+ l (/ Ls (FIX(/ Ls 0.4))))中的0.4修改即可。
☆;;多义线摹拟缓和曲线。
;;输入起止直线、半径、缓和曲线长或设计车速。
;;命令：HH(defun com_p()(setq l 0)(command "ucs" "o" (list (- 0 x1) 0 0))(command "pline" (list 0 0 0) "w" "0" ""(repeat (FIX(/ Ls 0.4))(setq l (+ l (/ Ls (FIX(/ Ls 0.4))))x (+ (- l (/ (* l l l l l) 40 C C)) (/ (* l l l l l l l l l) 3456 C C C C))y (* id__ (+ (- (/ (* l l l) 6 C) (/ (* l l l l l l l) 336 C C C)) (/ (* l l l l l l l l l l l) 42240 C C C C C))));setq(command (list x y 0)));repaet);command(setq pt5 (trans (list x y 0) 1 0)));com_p(defun ll_v()(setq V (getreal "\nGive Velocity:")Ls1 (* V 0.85)Ls2 (/ (* 0.0357 V V V) R)Ls (max Ls1 Ls2 (/ R 9))Ls (* (fix (/ Ls 10)) 10.0));setq(if (> Ls R) (setq Ls R))(ll_d));ll_v(defun ll_d()(setq os (getvar "osmode"))(setvar "osmode" 0)(setq C (* Ls R)q (- (+ (- (/ Ls 2) (/ (* Ls Ls Ls) 240 R R)) (/ (* Ls Ls Ls Ls Ls) 34560 R R R R)) (/(* Ls Ls Ls Ls Ls Ls Ls) 8386560 R R R R R R))pt1 (cdr (assoc 10 (entget (car p1))))pt2 (cdr (assoc 11 (entget (car p1))))pt10(polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))pt3 (cdr (assoc 10 (entget (car p2))))pt4 (cdr (assoc 11 (entget (car p2))))pt20(polar pt3 (angle pt3 pt4) (/ (distance pt3 pt4) 2))p (+ (- (/ (* Ls Ls) 24 R) (/ (* Ls Ls Ls Ls) 2688 R R R)) (/ (* Ls Ls Ls Ls Ls Ls) 506880 R R R R R))jd (inters pt1 pt2 pt3 pt4 nil)alf1(angle pt10 jd)alf2(angle pt20 jd)alf (- (angle jd pt20) alf1));setq(if (or (> alf pi) (and (< alf 0) (> alf (- 0 pi))))(progn(setq id__ -1)(if (> alf pi) (setq alf (- (+ pi pi) alf)) (setq alf (abs alf))));progn(progn(setq id__ 1)(if (<= alf (- 0 pi)) (setq alf (+ pi pi alf))));progn);if(setq x0 (/ (* (+ p R) (sin(/ alf 2.0))) (cos(/ alf 2.0)))x1 (+ x0 q)Cl (+ (* alf R) Ls)E (- (/ (+ R p) (cos(/ alf 2))) R));setq(command "ucs" "o" jd)(command "ucs" "z" (/ (* 180 alf1) pi))(com_p) (setq pt6 pt5)(setq ppt1 (list x1 0 0))(command "ucs" "")(command "ucs" "o" jd)(command "ucs" "z" (/ (* 180 alf2) pi))(setq id__ (- 0 id__)) (com_p)(setq ppt2 (list x1 0 0))(command "ucs" "")(if (> (abs(distance jd pt1)) (abs(distance jd pt2)))(setq ptt1 pt1)(setq ptt1 pt2));if(setq ptt2 (polar jd alf1 (- 0 x1)))(thh p1 ptt1 10)(thh p1 ptt2 11)(if (> (abs(distance jd pt3)) (abs(distance jd pt4)))(setq ptt3 pt3)(setq ptt3 pt4));if(setq ptt4 (polar jd alf2 (- 0 x1)))(thh p2 ptt3 10)(thh p2 ptt4 11)(if (= id__ 1) (command "arc" pt5 "e" pt6 "r" R) (command "arc" pt6 "e" pt5 "r" R)) (setq alfd (angf alf))(setvar "osmode" os)(command "cmdecho" "1")(command "text" pause pause "" (strcat "偏角＝" alfd))(command "cmdecho" "0")(command "text" "" (strcat "半径＝" (rtos R 2 2)))(command "text" "" (strcat "切线长＝" (rtos x1 2 2)))(command "text" "" (strcat "曲线长＝" (rtos Cl 2 2)))(command "text" "" (strcat "外距＝" (rtos E 2 2)))(command "text" "" (strcat "缓曲长＝" (rtos Ls 2 2))));ll_d(defun angf (alf)(setq alff (angtos alf 1 4)n 1kk (strlen alff))(repeat kk(setq alfn (substr alff n 1))(if (= alfn "d")(setq nn n));if(setq n (+ n 1)));repeat(strcat (substr alff 1 (- nn 1)) "%%" (substr alff nn)));angf(defun c:hh(/ p1 p2 pt1 pt2 pt3 pt4 pt5 pt6 pt10 pt20 id__ R V Ls E p3r1 x y l x0 x1 C jd alf alf1 alf2 q p Cl Ls1 Ls2)(command "ucs" "")(setq p1 nil p2 nil)(while (= p1 nil) (setq p1 (entsel "\n拾取第一条直线:")))(redraw (car p1) 3)(while (= p2 nil) (setq p2 (entsel "\n拾取第二条直线:")))(redraw (car p2) 3)(initget 1)(setq R (getdist "\n请输入圆曲线半径R: "))(initget 1 "Ls V")(setq p3 (getdist "\n输入缓和曲线长度(Ls)或[设计速度(V)]：")) (if (= p3 "V") (ll_v) (progn (setq ls p3) (ll_d)))(princ));eline(defun thh(len pt h)(setq en_data (entget (car len))old_data (assoc h en_data)new_data (cons h pt)en (subst new_data old_data en_data));setq(entmod en));thh。
CAD二次开发(LISP)
第5行：（defun C: triang1() 本行中，defun为一个AutoLISP函数，它定义了函数TRIANG1。TRIANG1 为该函数的函数名。由于此函数名前带有Ｃ：，因此该函数可以像AutoCAD 命令一样被执行。若没有Ｃ：, TRIANG1命令只能置于圆括号中执行（TRIANG1）。此函数带有三个全 局变量（ P1,P2，P3）。第一次编写AutoLISP程序时，保持变量为全局变量是个好 习惯。这是因为装入并运行程序后，可以通过在AutoCAD命令提示行中输人 感叹号（！）并在其后输入变量名来检查变量的值（Command：！P1）。一 旦程序通过测试并运行正常，就应该使它们成为局部变量(defun ｃ：TRIANG1（／P1 P2 P3） 第6行：（setq P1（getpoint“\ｎ Enter first Point ｏｆ triangle："）） 本行中，getpoint函数暂停程序的运行，允许用户输入三角形的第一个点。 提示信息Enter first Point of triangle显示在屏幕的提示区内。可以通过键盘输入该点的坐标，也可以用 屏幕光标选择该点。随后setq函数将这些坐标赋予变量P1。＼ｎ的作用是回车， 其后的表达式将被打印在下一行上（“ｎ”代表“ｎｅｗｌｉｎｅ"）
说明
1 2 3 4 5 6 7 8 9
10
第1－3行 前三行为注释行，用于描述程序中的函数。这几行很重要因为有它们，编 辑程序会变得简单一些。可以在任何必要的时候使用注释。所有的注释行都 必须以分号（；）开头，当程序装入时这些行会被忽略。 第4行：行为空行，用于分隔程序与注释部分。空行还可以用来分隔程序 的不同模块。这样便于区分程序的不同部分。空行对程序没有影响。再 Nhomakorabea加几个函数
AutoCAD-LISP实用程序
(setvar "plinetype" 0)
(setq pt0 (getpoint "\n 请输入视图的中心位置点:"))
(initget 7)
(setq loop T)
(while loop
(setq d (getreal "\n 请输入键槽处的轴径(12<d<130)(mm):"))
(if (= CTYPE "E") (setq INC INC1) (setq INC INC))
(if (= CTYPE "N") (setq INC INC3) (setq INC INC))
(setq TMS (FIX (+ 0.00001 (/ DIST INC))))
(setvar "OSMODE" 0)
多重复制
(defun C:CM ()
(setq A nil)
(setq OM (getvar "OSMODE"))
(setvar "OSMODE" 33)
(setq PNT1 (getpoint "\n拾取第一点： "))
(setq PNT2 (getpoint "\n拾取第二点： " PNT1))(terpri)
(setq A (ssget))
(setq INCR 0)
(repeat TMS
(setq INCR (+ INCR INC))
(setq NEWPT (polar PNT1 ANG INCR))
cad自动写标高lisp
cad自动写标高lispcad自动写标高lisp;;自动标高主程序(使用方法:新建文件，后缀名为.lsp，将全部内容粘贴过去，然后将lsp文件拖进cad窗口(即加载)，输入命令xbg，按命令行提示操作即可)(defun c:xbg(/ xs_d os dim jd i_sc i_bg i_uni bg_jz pt_jz zb_jz pt_nt zb_nt bg_nt)(setvar "cmdecho" 0)(setvar "dimzin" 0)(setvar "blipmode" 0)(setq xs_d (getvar "dimzin"))(setq os (getvar "osmode"))(setq dim (getvar "dimzin"))(chk_style)(princ "\n适用于真实尺寸作图")(setq i_uni (getstring "\n图纸单位是mm/cm/m:")) (if (= "" i_uni) (setq i_uni "cm"))(cond ((= i_uni "mm") (setq i_bg 1000.0))((= i_uni "cm") (setq i_bg 100.0))((= i_uni "m") (setq i_bg 1.0))(t (setq i_bg 1.0)))(if (setq jd (getint "\n标高有效位数<3>:")) () (setq jd 3))(if (setq i_sc (getreal "\n比例系数<1>:")) () (setq i_sc 1))(if (setq bg_jz (getreal "\n输入基准点标高<100.0>:")) () (setq bg_jz 100.0))(setq pt_jz (getpoint "\n指定基准点:"))(setq zb_jz (cadr pt_jz))(d_fh pt_jz bg_jz) ;绘制基准点(while (setq pt_nt (getpoint "\n指定下一点:"))(progn(setq zb_nt (cadr pt_nt))(setq bg_nt (+ bg_jz (/ (- zb_nt zb_jz) i_bg)))(d_fh pt_nt bg_nt);绘制标准点))(setvar "dimzin" xs_d)(setvar "dimzin" dim));;测试子程序(defun c:css(/ pt bg)(setq pt (getpoint "\n````"))(setq bg 100.0)(setq jd 2)(setq i_sc 1)(d_fh));;标注标高(defun d_fh(pt bg / pt1)(setvar "osmode" 0)(command "line" (polar pt 0 (* 3.0 i_sc)) (polar pt 0 (* 7.0 i_sc)) "")(command "line" (polar pt 0 (* 5.0 i_sc)) (polar (polar pt 0 (* 5.0 i_sc)) (/ pi 3) (* 3.0 i_sc)) "")(command "line" (polar pt 0 (* 5.0 i_sc)) (polar (polar pt 0 (* 5.0 i_sc)) (* 2 (/ pi 3)) (* 3.0 i_sc)) "")(command "line" (polar (polar pt 0 (* 5.0 i_sc)) (* 2 (/ pi 3)) (* 3.0 i_sc)) (polar (polar (polar pt 0 (* 5.0 i_sc)) (* 2 (/ pi 3)) (* 3.0i_sc)) 0 (* 12.0 i_sc)) "")(setq pt1 (polar (polar (polar pt 0 (* 5.0 i_sc)) (* 2 (/ pi 3)) (* 3.0 i_sc)) 0 (* 6.0 i_sc)))(command "_.text" "j" "m" (polar pt1 (/ pi 2) (* 1.8 i_sc)) (* 2.5 i_sc) "0" (rtos bg 2 jd))(setvar "osmode" os))(defun chk_style();检查字型(setq chksty(tblsearch "style" "standa"))(if (null chksty)(progn(command "_style" "standa" "fsdb" "0" "0.7" "0" "n" "n" "n") ))(setq chklay(tblsearch "layer" "文本"))(if (null chklay)(command "_layer" "m" "文本" "c" "3" "文本" ""))(setvar "clayer" "文本")(setvar "textstyle" "standa"))(princ "\n--自动写标高程序--hez87")(prin1)---------------------------------------------------------------范文最新推荐------------------------------------------------------ 财务管理工作总结[财务管理工作总结]2009年上半年，我们驻厂财会组在公司计财部的正确领导下，在厂各部门的大力配合下，全组人员尽“参与、监督、服务”职能，以实现企业生产经营目标为核心，以成本管理为重点，全面落实预算管理，加强会计基础工作，充分发挥财务管理在企业管理中的核心作用，较好地完成了各项工作任务，财务管理水平有了大幅度的提高，财务管理工作总结。
cad画缓和曲线lisp程序(1)
CAD中画缓和曲线，首先复制本文☆后面的源程序保存至cad安装目录的SUPPORT文件夹，保存类型为.lsp 可以随便复制一个SUPPORT文件夹内的lsp文件，然后替换本文的程序。
打开CAD后，输入appload回车，找到你保存的缓和曲线lsp程序，点击加载，然后就可以画缓和曲线了。
首先，要画出缓和曲线的两条直线，然后输入HH回车，按提示完成缓和曲线。
注：本程序，缓和曲线段拟合长度为，如需更改拟合长度，将程序的第8行(repeat (FIX(/ Ls )及9行(setq l (+ l (/ Ls (FIX(/ Ls )))中的修改即可。
☆;;多义线摹拟缓和曲线。
;;输入起止直线、半径、缓和曲线长或设计车速。
;;命令：HH(defun com_p()(setq l 0)(command "ucs" "o" (list (- 0 x1) 0 0))(command "pline" (list 0 0 0) "w" "0" ""(repeat (FIX(/ Ls )(setq l (+ l (/ Ls (FIX(/ Ls )))x (+ (- l (/ (* l l l l l) 40 C C)) (/ (* l l l l l l l l l) 3456 C C C C))y (* id__ (+ (- (/ (* l l l) 6 C) (/ (* l l l l l l l) 336 C C C)) (/ (* l l l l l l l l l l l) 42240 C C C C C))));setq(command (list x y 0)));repaet);command(setq pt5 (trans (list x y 0) 1 0)));com_p(defun ll_v()(setq V (getreal "\nGive Velocity:")Ls1 (* VLs2 (/ (* V V V) R)Ls (max Ls1 Ls2 (/ R 9))Ls (* (fix (/ Ls 10)));setq(if (> Ls R) (setq Ls R))(ll_d));ll_v(defun ll_d()(setq os (getvar "osmode"))(setvar "osmode" 0)(setq C (* Ls R)q (- (+ (- (/ Ls 2) (/ (* Ls Ls Ls) 240 R R)) (/ (* Ls Ls Ls Ls Ls) 34560 R R R R)) (/ (* Ls Ls Ls Ls Ls Ls Ls) 8386560 R R R R R R)) pt1 (cdr (assoc 10 (entget (car p1))))pt2 (cdr (assoc 11 (entget (car p1))))pt10(polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))pt3 (cdr (assoc 10 (entget (car p2))))pt4 (cdr (assoc 11 (entget (car p2))))pt20(polar pt3 (angle pt3 pt4) (/ (distance pt3 pt4) 2))p (+ (- (/ (* Ls Ls) 24 R) (/ (* Ls Ls Ls Ls) 2688 R R R)) (/ (* Ls Ls Ls Ls Ls Ls) 506880 R R R R R))jd (inters pt1 pt2 pt3 pt4 nil)alf1(angle pt10 jd)alf2(angle pt20 jd)alf (- (angle jd pt20) alf1));setq(if (or (> alf pi) (and (< alf 0) (> alf (- 0 pi))))(progn(setq id__ -1)(if (> alf pi) (setq alf (- (+ pi pi) alf)) (setq alf (abs alf))));progn(progn(setq id__ 1)(if (<= alf (- 0 pi)) (setq alf (+ pi pi alf))));progn);if(setq x0 (/ (* (+ p R) (sin(/ alf )) (cos(/ alf ))x1 (+ x0 q)Cl (+ (* alf R) Ls)E (- (/ (+ R p) (cos(/ alf 2))) R));setq(command "ucs" "o" jd)(command "ucs" "z" (/ (* 180 alf1) pi))(com_p) (setq pt6 pt5)(setq ppt1 (list x1 0 0))(command "ucs" "")(command "ucs" "o" jd)(command "ucs" "z" (/ (* 180 alf2) pi))(setq id__ (- 0 id__)) (com_p)(setq ppt2 (list x1 0 0))(command "ucs" "")(if (> (abs(distance jd pt1)) (abs(distance jd pt2)))(setq ptt1 pt1)(setq ptt1 pt2));if(setq ptt2 (polar jd alf1 (- 0 x1)))(thh p1 ptt1 10)(thh p1 ptt2 11)(if (> (abs(distance jd pt3)) (abs(distance jd pt4)))(setq ptt3 pt3)(setq ptt3 pt4));if(setq ptt4 (polar jd alf2 (- 0 x1)))(thh p2 ptt3 10)(thh p2 ptt4 11)(if (= id__ 1) (command "arc" pt5 "e" pt6 "r" R) (command "arc" pt6 "e" pt5 "r" R))(setq alfd (angf alf))(setvar "osmode" os)(command "cmdecho" "1")(command "text" pause pause "" (strcat "偏角＝" alfd))(command "cmdecho" "0")(command "text" "" (strcat "半径＝" (rtos R 2 2)))(command "text" "" (strcat "切线长＝" (rtos x1 2 2)))(command "text" "" (strcat "曲线长＝" (rtos Cl 2 2)))(command "text" "" (strcat "外距＝" (rtos E 2 2)))(command "text" "" (strcat "缓曲长＝" (rtos Ls 2 2))));ll_d(defun angf (alf)(setq alff (angtos alf 1 4)n 1kk (strlen alff))(repeat kk(setq alfn (substr alff n 1))(if (= alfn "d")(setq nn n));if(setq n (+ n 1)));repeat(strcat (substr alff 1 (- nn 1)) "%%" (substr alff nn)));angf(defun c:hh(/ p1 p2 pt1 pt2 pt3 pt4 pt5 pt6 pt10 pt20 id__ R V Ls E p3r1 x y l x0 x1 C jd alf alf1 alf2 q p Cl Ls1 Ls2)(command "ucs" "")(setq p1 nil p2 nil)(while (= p1 nil) (setq p1 (entsel "\n拾取第一条直线:")))(redraw (car p1) 3)(while (= p2 nil) (setq p2 (entsel "\n拾取第二条直线:")))(redraw (car p2) 3)(initget 1)(setq R (getdist "\n请输入圆曲线半径R: "))(initget 1 "Ls V")(setq p3 (getdist "\n输入缓和曲线长度(Ls)或[设计速度(V)]： ")) (if (= p3 "V") (ll_v) (progn (setq ls p3) (ll_d)))(princ));eline(defun thh(len pt h)(setq en_data (entget (car len))old_data (assoc h en_data)new_data (cons h pt)en (subst new_data old_data en_data));setq(entmod en));thh。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
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)))(setqpp2 (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 命令,就可以删除红色的图元了.。