CAD lisp 实用小程序(源代码)
AutoLisp 源代码 实用程序1
(defun c:1 ( / 1a 1b 1c 1d chklay do va vx)(setvar "OSMODE" 1024)(setq chklay (tblsearch "layer" "FL"))(if (null chklay)(command "layer" "n" "FL" "c" "161" "FL" "") )(setq va (getvar "lunits"))(if (= va 2)(progn(setq do 20000)(SETQ VX 1)))(if (= va 4)(progn(setq do 800)(SETQ VX 0.03937)))(setq 1a '(0 0 0))(setq 1b (polar 1a 0 do))(setq 1c (polar 1b (* pi 0.5) do))(setq 1d (polar 1a (* pi 0.5) do))(command "pline" 1a 1b 1c 1d 1a "")(command "chprop" (entlast) "" "la" "FL" "")(command "insert" "STR BLOCK" '(0 0 0) VX VX 0) (setvar "OSMODE" 1279)(prin1))(defun c:dxff (/ ent)(setq a1 (car (entsel)))(setq b1 (entget a1 (list "*"))));;;(defun c:e(/ cmd_ent cmd_sel cmd_no);;; (setq cmd_ent (cadr (ssgetfirst)));;; (cond ((= nil cmd_ent);;; (setq cmd_sel (ssget));;; (setq cmd_no (sslength cmd_sel));;; (command "_.erase" cmd_sel "");;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; "\nTotal **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; "\nTotal **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; );;; );;; );;; ((/= nil cmd_ent);;; (setq cmd_no (sslength cmd_ent));;; (command "_.erase");;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; "\nTotal **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; "\nTotal **** ";;; (rtos cmd_no 2 0);;; " **** Deleted";;; );;; );;; );;; );;; (princ);;; );******************************************************************************* ********************************************************************;;;(defun c:m (/ cmd_ent cmd_sel cmd_no cmd_dist cmd_pt cmd_pt1);;; (setq cmd_ent (cadr (ssgetfirst)));;; (if (= nil cmd_ent);;; (setq cmd_sel (ssget));;; (setq cmd_sel cmd_ent);;; );;; (setq cmd_no (sslength cmd_sel));;; (princ (strcat (rtos cmd_no 2 0) " Found By Elvis"));;; (command "move";;; cmd_sel;;; "";;; (setq;;; cmd_pt (getpoint;;; "\nSpecify base point or [Displacement] <Displacement>: ";;; );;; );;; pause;;; );;; (setq cmd_pt1 (getvar "lastpoint"));;; (setq cmd_dist (distance cmd_pt cmd_pt1));;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Moved";;; "\n";;; "\nStartPoint **** (";;; (rtos (car cmd_pt) 2 4);;; ", ";;; (rtos (cadr cmd_pt) 2 4);;; ", ";;; (rtos (caddr cmd_pt) 2 4);;; " )****";;; "\n";;; "\nEndPoint **** (";;; (rtos (car cmd_pt1) 2 4);;; ", ";;; (rtos (cadr cmd_pt1) 2 4);;; ", ";;; (rtos (caddr cmd_pt1) 2 4);;; " )****";;; "\n";;; "\nDistance **** ";;; (rtos cmd_dist 2 4);;; " **** ";;; );;; );;;;;; (Propak_Str_Elvis cmd_sel a "MOVE");;; (princ);;;);;;(defun c:co ( / cmd_copyent cmd_dist cmd_ent cmd_entlast cmd_no cmd_pt cmd_pt1 cmd_sel);;; (SETQ A (GETVAR "OSMODE"));;; (setq cmd_ent (cadr (ssgetfirst)));;; (if (= nil cmd_ent);;; (setq cmd_sel (ssget));;; (setq cmd_sel cmd_ent);;; );;; (setq cmd_no (sslength cmd_sel));;; (princ (strcat (rtos cmd_no 2 0) " Found By Elvis"));;; (setq cmd_pt;;; (getpoint;;; "\nSpecify second point or [Array] <use first point as displacement>:" ;;; );;; );;; (while t;;; (setq cmd_copyent (ssadd));;; (setq cmd_entlast (entlast));;; (command "copy" cmd_sel "" cmd_pt pause);;; (setq cmd_pt1 (getvar "lastpoint"));;; (setq cmd_dist (distance cmd_pt cmd_pt1));;;;;; (while (if (= cmd_entlast nil) nil (setq cmd_entlast (entnext cmd_entlast))) ;;; (if (member (cdr (assoc 0 (entget cmd_entlast)));;; '("LINE" "CIRCLE" "LWPOLYLINE";;; "TEXT" "3DSOLID" "ELLIPSE";;; "ARC" "DIMENSION" "LEADER";;; "POLYLINE" "MTEXT" "INSERT";;; );;; );;; (setq cmd_copyent (ssadd cmd_entlast cmd_copyent));;; ));;;;;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Copy";;; "\n";;; "\nStartPoint **** (";;; (rtos (car cmd_pt) 2 4);;; ", ";;; (rtos (cadr cmd_pt) 2 4);;; ", ";;; (rtos (caddr cmd_pt) 2 4);;; " )****";;; "\n";;; "\nEndPoint **** (";;; (rtos (car cmd_pt1) 2 4);;; ", ";;; (rtos (cadr cmd_pt1) 2 4);;; ", ";;; (rtos (caddr cmd_pt1) 2 4);;; " )****";;; "\n";;; "\nDistance **** ";;; (rtos cmd_dist 2 4);;; " **** ";;; );;; );;; (Propak_Str_RevText cmd_copyent);;; (Propak_Str_Elvis cmd_copyent a "COPY");;;;;; );;;;;; (princ);;;);;;(defun c:mi ( / cmd_copyent cmd_dist cmd_ent cmd_entlast cmd_method cmd_no cmd_pt cmd_pt1 cmd_sel cmd_st);;; (setq cmd_ent (cadr (ssgetfirst)));;; (if (= nil cmd_ent);;; (setq cmd_sel (ssget));;; (setq cmd_sel cmd_ent);;; );;; (setq cmd_no (sslength cmd_sel));;; (princ (strcat (rtos cmd_no 2 0) " Found By Elvis"));;; (setq cmd_pt;;; (getpoint;;; "\nSpecify second point or [Array] <use first point as displacement>:" ;;; );;; );;; (setq cmd_copyent (ssadd));;; (setq cmd_entlast (entlast));;; (command "mirror" cmd_sel "" cmd_pt pause "N");;; (setq cmd_pt1 (getvar "lastpoint"));;; (setq cmd_dist (distance cmd_pt cmd_pt1));;;;;; (setq cmd_st (strcase (getstring "\nErase source objects? [Yes/No] <N>: "))) ;;; (if (= cmd_st "Y");;; (progn;;; (setq cmd_method "MOVE");;; (command "erase" cmd_sel "");;; );;; (setq cmd_method "COPY");;;;;; );;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Mirror";;; "\n";;; "\nStartPoint **** (";;; (rtos (car cmd_pt) 2 4);;; ", ";;; (rtos (cadr cmd_pt) 2 4);;; ", ";;; (rtos (caddr cmd_pt) 2 4);;; " )****";;; "\n";;; "\nEndPoint **** (";;; (rtos (car cmd_pt1) 2 4);;; ", ";;; (rtos (cadr cmd_pt1) 2 4);;; ", ";;; (rtos (caddr cmd_pt1) 2 4);;; " )****";;; "\n";;; "\nDistance **** ";;; (rtos cmd_dist 2 4);;; " **** ";;; );;; );;; (while (setq cmd_entlast (entnext cmd_entlast));;; (if (member (cdr (assoc 0 (entget cmd_entlast)));;; '("LINE" "CIRCLE" "LWPOLYLINE" "TEXT" "3DSOLID";;; "ELLIPSE" "ARC" "DIMENSION" "LEADER" "POLYLINE" "MTEXT" "INSERT") ;;; );;; (setq cmd_copyent (ssadd cmd_entlast cmd_copyent));;; );;; );;; (Propak_Str_RevText cmd_copyent);;; (Propak_Str_Elvis cmd_copyent a cmd_method);;;;;; (princ);;;);;;(defun c:s (/ cmd_ent cmd_sel cmd_no cmd_dist cmd_pt cmd_pt1);;; (setq cmd_ent (cadr (ssgetfirst)));;; (if (= nil cmd_ent);;; (setq cmd_sel (ssget));;; (setq cmd_sel cmd_ent);;; );;; (setq cmd_no (sslength cmd_sel));;; (princ (strcat (rtos cmd_no 2 0) " Found By Elvis"));;; (command "stretch";;; cmd_sel;;; "";;; (setq;;; cmd_pt (getpoint;;; "\nSpecify base point or [Displacement] <Displacement>: " ;;; );;; );;; pause;;; );;; (setq cmd_pt1 (getvar "lastpoint"));;; (setq cmd_dist (distance cmd_pt cmd_pt1));;; (alert (strcat "Total **** ";;; (rtos cmd_no 2 0);;; " **** Moved";;; "\n";;; "\nStartPoint **** (";;; (rtos (car cmd_pt) 2 4);;; ", ";;; (rtos (cadr cmd_pt) 2 4);;; ", ";;; (rtos (caddr cmd_pt) 2 4);;; " )****";;; "\n";;; "\nEndPoint **** (";;; (rtos (car cmd_pt1) 2 4);;; ", ";;; (rtos (cadr cmd_pt1) 2 4);;; ", ";;; (rtos (caddr cmd_pt1) 2 4);;; " )****";;; "\n";;; "\nDistance **** ";;; (rtos cmd_dist 2 4);;; " **** ";;; );;; );;; (Propak_Str_Elvis cmd_sel a "STRETCH");;; (princ);;;);============(defun Propak_Str_Elvis (Elvis_Sel a Elvis_method /Elvis_rno Elvis_dataElvis_T Elvis_typElvis_colo Elvis_colo_bkElvis_xdata)(if (= a "!1")(progn(regapp "PROPAK_ELVIS")(setq Elvis_rno 0)(repeat (sslength Elvis_Sel)(setq Elvis_data (entget (ssname Elvis_Sel Elvis_rno)))(if (= nil (assoc -3 (entget (ssname Elvis_Sel Elvis_rno) (list "*")))) (setq Elvis_T t)(setq Elvis_T nil))(setq Elvis_typ (cdr (assoc 0 Elvis_data)))(setq Elvis_colo (cdr (assoc 62 Elvis_data)))(if (= Elvis_colo nil)(setq Elvis_colo_bk 256)(setq Elvis_colo_bk Elvis_colo))(cond ((and (or (= Elvis_typ "LINE")(= Elvis_typ "CIRCLE")(= Elvis_typ "LWPOLYLINE")(= Elvis_typ "TEXT")(= Elvis_typ "3DSOLID")(= Elvis_typ "ELLIPSE")(= Elvis_typ "ARC")(= Elvis_typ "POLYLINE")(= Elvis_typ "MTEXT"))Elvis_T)(setq Elvis_xdata(list '-3(cons "PROPAK_ELVIS"(list '(1002 . "{")(cons 1000 (rtos Elvis_colo_bk 2 0))(cons 1000 Elvis_method)'(1002 . "}")))))(entmod (append Elvis_data (list (cons 62 10)) (list Elvis_xdata))) ))(setq Elvis_rno (1+ Elvis_rno))))))(defun Propak_Str_RevText (RevText_Sel / dcl_id dd ent revtext_data revtext_name revtext_rno revtext_typ)(setq RevText_rno 0)(repeat (sslength RevText_Sel)(setq RevText_data (entget (ssname RevText_Sel RevText_rno)))(setq RevText_typ (cdr (assoc 0 RevText_data)))(cond ((or (= RevText_typ "TEXT")(= RevText_typ "MTEXT"))(setq ent (cdr (assoc 1 RevText_data)))(setq dcl_id (load_dialog "dde"))(new_dialog "dde" dcl_id)(set_tile "dimt" ent)(action_tile "accept" "(getdata) (done_dialog 1)")(action_tile "cancle" "(done_dialog)")(setq dd (start_dialog))(if (= dd 1)(entmod (subst (cons 1 ent) (assoc 1 RevText_data) RevText_data))))((= RevText_typ "INSERT")(if (= "SUPTAG" (cdr (assoc 2 RevText_data)))(progn(setq RevText_name(entnext (ssname RevText_Sel RevText_rno)))(setq RevText_data (entget RevText_name))(setq ent (cdr (assoc 1 RevText_data)))(setq dcl_id (load_dialog "dde"))(new_dialog "dde" dcl_id)(set_tile "dimt" ent)(action_tile "accept" "(getdata) (done_dialog 1)")(action_tile "cancle" "(done_dialog)")(setq dd (start_dialog))(if (= dd 1)(entmod (subst (cons 1 ent)(assoc 1 RevText_data)RevText_data)))))))(setq RevText_rno (1+ RevText_rno))))(defun getdata()(setq ent (get_tile "dimt")))(defun c:zx( / cadr_typ cmd_rno cmd_t cmdr_colo cmdr_data cmdr_lst cmdr_name cmdr_sel)(setq cmdr_sel (ssget))(setq cmd_rno 0)(setq cmdr_lst '((-3 ("PROPAK_ELVIS"))))(repeat (sslength cmdr_sel)(setq cmdr_data (entget (ssname cmdr_sel cmd_rno)))(setq cadr_typ (cdr (assoc 0 cmdr_data)))(if (= "PROPAK_ELVIS" (caadr (assoc -3 (entget (ssname cmdr_sel cmd_rno) (list "*")))))(setq cmd_T t)(setq cmd_T nil))(cond ((and (or (= cadr_typ "LINE")(= cadr_typ "CIRCLE")(= cadr_typ "LWPOLYLINE")(= cadr_typ "TEXT")(= cadr_typ "3DSOLID")(= cadr_typ "ELLIPSE")(= cadr_typ "ARC")(= cadr_typ "POLYLINE")(= cadr_typ "MTEXT"))cmd_T)(setq cmdr_colo (atoi (cdr (nth 2 (cadr (assoc -3 (entget (ssname cmdr_sel cmd_rno) (list "*"))))))))(entmod (setq cmdr_data (subst (cons 62 cmdr_colo) (assoc 62 cmdr_data) cmdr_data)))(entmod (append cmdr_data cmdr_lst)))((= cadr_typ "INSERT")(if (or (= "SUPTAG" (cdr (assoc 2 cmdr_data)))(= "bom1" (cdr (assoc 2 cmdr_data)))(= "BOM1" (cdr (assoc 2 cmdr_data))))(progn(setq cmdr_name(ssname cmdr_sel cmd_rno))(setq cmdr_data (entget cmdr_name))(while (/= "SEQEND" (cdr (assoc 0 cmdr_data)))(setq cmdr_name (entnext cmdr_name))(setq cmdr_data (entget cmdr_name))(assoc 62 cmdr_data)(if (/= nil (assoc 62 cmdr_data))(progn(entmod (setq cmdr_data (subst (cons 62 256)(assoc 62 cmdr_data)cmdr_data))))))))))(setq cmd_rno (1+ cmd_rno)) )(princ))。
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 命令,就可以删除红色的图元了.。
五个实用的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、删除带颜色图元以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次。
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插件⾯板快捷键LISP源码教程Cad插件⾯板快捷键LISP源码实例Cad插件⾯板如下：⾯板快捷键效果如下：下边是源码：(DEFUN G ETTOOLS P ATH (/ TMP)(SETQ TMP"C:\\W INDOWS\\K_COM.TXT"))(DEFUN K_KJJ(/ DCL_ID D CL_F ILE D IALOG_R ETURN KEYS KEY LST1 FFK TMP UI% XJ E1 B A FF ) (VL-LOAD-COM)(SETQ DCL_ID (LOAD_DIALOG (SETQ D CL_F ILE (W RITE_D CL_F ORM1))))(VL-FILE-DELETE D CL_F ILE)(SETQ D IALOG_R ETURN 2)(WHILE (>D IALOG_R ETURN 1)(NEW_DIALOG "F ORM1" DCL_ID)(SETQ KEYS '("T EXT1""T EXT2""T EXT3""T EXT4""T EXT5""T EXT6""T EXT7""T EXT8" "T EXT9""T EXT10" "T EXT11""T EXT12""T EXT13""T EXT14""T EXT15""T EXT16""T EXT17""T EXT18" "T EXT19""T EXT20" "T EXT21""T EXT22""T EXT23""T EXT24""T EXT25""T EXT26""T EXT27""T EXT28" "T EXT29""T EXT30" "T EXT31""T EXT32""T EXT33""T EXT34""T EXT35""T EXT36""T EXT37""T EXT38" "T EXT39""T EXT40" "T EXT41""T EXT42""T EXT43""T EXT44""T EXT45""T EXT46""T EXT47""T EXT48" "T EXT49""T EXT50" "T EXT51""T EXT52""T EXT53""T EXT54""T EXT55""T EXT56""T EXT57""T EXT58" "T EXT59""T EXT60" "T EXT61""T EXT62""T EXT63""T EXT64""T EXT65""T EXT66""T EXT67""T EXT68" "T EXT69""T EXT70" "T EXT71""T EXT72""T EXT73""T EXT74""T EXT75""T EXT76""T EXT77""T EXT78" "T EXT79""T EXT80" "T EXT81""T EXT82""T EXT83""T EXT84""T EXT85""T EXT86""T EXT87""T EXT88" "T EXT89""T EXT90" "T EXT91""T EXT92""T EXT93""T EXT94""T EXT95""T EXT96""T EXT97""T EXT98" "T EXT99""T EXT100" "ACCEPT""CANCEL"))(FOREACH KEY KEYS(IF (EVAL (READ KEY ))(SET_TILE KEY (EVAL (READ KEY ))))(ACTION_TILE KEY "(A CTION_F ORM1_K EYS $KEY )"))(SETQ LST1'())(IF(SETQ FFK(OPEN (G ETTOOLS P ATH)"R"))(PROGN(WHILE (SETQ TMP (READ-LINE FFK))(SETQ LST1(CONS TMP LST1)))(CLOSE FFK)(SETQ LST1(REVERSE LST1))(SETQ UI%0)(REPEAT (LENGTH LST1)(SETQ XJ (NTH UI% LST1))(SETQ E1(VL-STRING-POSITION (ASCII ",") XJ)) (SETQ B (SUBSTR XJ 1 E1))(SETQ A (SUBSTR XJ (+ E12)))(SET_TILE (STRCAT "T EXT"(ITOA (+ UI%1))) B) (SETQ UI%(+1 UI%))))(PROGN;;;图层显⽰(SET_TILE "T EXT1""LL")(SET_TILE "T EXT2""LK")(SET_TILE "T EXT3""LP")(SET_TILE "T EXT4""LY")(SET_TILE "T EXT5""LO")(SET_TILE "T EXT6""LU")(SET_TILE "T EXT7""ACC")(SET_TILE "T EXT8""L0")(SET_TILE "T EXT9""CV")(SET_TILE "T EXT10""CY")(SET_TILE "T EXT11""CD")(SET_TILE "T EXT12""VV")(SET_TILE "T EXT13""VH")(SET_TILE "T EXT14""VA")(SET_TILE "T EXT15""KM")(SET_TILE "T EXT16""FS")(SET_TILE "T EXT17""LC")(SET_TILE "T EXT18""SZC")(SET_TILE "T EXT19""SXC")(SET_TILE "T EXT20""SDC");;;⽂本属性(SET_TILE "T EXT21""W2A")(SET_TILE "T EXT22""A2W")(SET_TILE "T EXT23""CA")(SET_TILE "T EXT24""ZX")(SET_TILE "T EXT25""C1")(SET_TILE "T EXT26""WHH")(SET_TILE "T EXT27""WW")(SET_TILE "T EXT28""WEE")(SET_TILE "T EXT29""WQQ")(SET_TILE "T EXT30""WX")(SET_TILE "T EXT31""WA")(SET_TILE "T EXT32""FW")(SET_TILE "T EXT33""WWS")(SET_TILE "T EXT35""YQ") (SET_TILE "T EXT36""YW") (SET_TILE "T EXT37""WY") (SET_TILE "T EXT38""ZS") (SET_TILE "T EXT39""XS") (SET_TILE "T EXT40""DZ");;;标注制图(SET_TILE "T EXT41""SS") (SET_TILE "T EXT42""QK") (SET_TILE "T EXT43""ER") (SET_TILE "T EXT44""OO") (SET_TILE "T EXT45""XX") (SET_TILE "T EXT46""FF") (SET_TILE "T EXT47""CC") (SET_TILE "T EXT48""CII") (SET_TILE "T EXT49""FL") (SET_TILE "T EXT50""FC") (SET_TILE "T EXT51""EEE") (SET_TILE "T EXT52""R2")(SET_TILE "T EXT53""RC") (SET_TILE "T EXT54""KL") (SET_TILE "T EXT55""TT") (SET_TILE "T EXT56""DF")(SET_TILE "T EXT57""JJ") (SET_TILE "T EXT58""L J") (SET_TILE "T EXT59""ZZ") (SET_TILE "T EXT60""Z0") ;;;专业制图(SET_TILE "T EXT61""YU") (SET_TILE "T EXT62""DP") (SET_TILE "T EXT63""HH") (SET_TILE "T EXT64""K0")(SET_TILE "T EXT65""ZC") (SET_TILE "T EXT66""ZD") (SET_TILE "T EXT67""JM") (SET_TILE "T EXT68""HF")(SET_TILE "T EXT69""HFA") (SET_TILE "T EXT70""HO") (SET_TILE "T EXT71""YK") (SET_TILE "T EXT72""FHM") (SET_TILE "T EXT73""HFS") (SET_TILE "T EXT74""CB")(SET_TILE "T EXT76""DK")(SET_TILE "T EXT77""TYC")(SET_TILE "T EXT78""D4")(SET_TILE "T EXT79""JC")(SET_TILE "T EXT80""JT");;;计量统计(SET_TILE "T EXT81""KI")(SET_TILE "T EXT82""BW")(SET_TILE "T EXT83""RK")(SET_TILE "T EXT84""KJ")(SET_TILE "T EXT85""KS")(SET_TILE "T EXT86""JK")(SET_TILE "T EXT87""S2E")(SET_TILE "T EXT88""XM")(SET_TILE "T EXT89""JMM")(SET_TILE "T EXT90""T2E")(SET_TILE "T EXT91""TW")(SET_TILE "T EXT92""MJE")(SET_TILE "T EXT93""DDE")(SET_TILE "T EXT94""WJY")(SET_TILE "T EXT95""WJX")(SET_TILE "T EXT96""ORE")(SET_TILE "T EXT97""RQ")(SET_TILE "T EXT98""YM")(SET_TILE "T EXT99""WK")(SET_TILE "T EXT100""A3")));--<--<-对话框初始化完成-<--<-- (SETQ D IALOG_R ETURN (START_DIALOG))) (SETQ FF (OPEN (G ETTOOLS P ATH)"W")) ;;;图层显⽰(WRITE-LINE (STRCAT TX1",""K_LL") FF) (WRITE-LINE (STRCAT TX2",""K_LK") FF) (WRITE-LINE (STRCATTX3",""K_LP") FF) (WRITE-LINE (STRCAT TX4",""K_LY") FF) (WRITE-LINE (STRCAT TX5",""K_LO") FF) (WRITE-LINE (STRCAT TX6",""K_LU") FF) (WRITE-LINE (STRCAT TX7",""K_ACC") FF) (WRITE-LINE (STRCAT TX8",""K_L0") FF) (WRITE-LINE (STRCAT TX9",""K_CV") FF) (WRITE-LINE (STRCAT TX10",""K_CY") FF) (WRITE-LINE (STRCATTX11",""K_CD") FF)(WRITE-LINE (STRCAT TX13",""K_VH") FF) (WRITE-LINE (STRCAT TX14",""K_VA") FF) (WRITE-LINE (STRCATTX15",""K_KM") FF) (WRITE-LINE (STRCAT TX16",""K_FS") FF) (WRITE-LINE (STRCAT TX17",""K_LC") FF) (WRITE-LINE (STRCAT TX18",""K_SZC") FF) (WRITE-LINE (STRCAT TX19",""K_SXC") FF) (WRITE-LINE (STRCATTX20",""K_SDC") FF) ;;;⽂本属性(WRITE-LINE (STRCAT TX21",""K_W2A") FF) (WRITE-LINE (STRCAT TX22",""K_A2W") FF) (WRITE-LINE (STRCATTX23",""K_CA") FF) (WRITE-LINE (STRCAT TX24",""K_ZX") FF) (WRITE-LINE (STRCAT TX25",""K_C1") FF) (WRITE-LINE (STRCAT TX26",""K_WHH") FF) (WRITE-LINE (STRCAT TX27",""K_WW") FF) (WRITE-LINE (STRCATTX28",""K_WEE") FF) (WRITE-LINE (STRCAT TX29",""K_WQQ") FF) (WRITE-LINE (STRCAT TX30",""K_WX") FF) (WRITE-LINE (STRCAT TX31",""K_WA") FF) (WRITE-LINE (STRCAT TX32",""K_FW") FF) (WRITE-LINE (STRCATTX33",""K_WWS") FF) (WRITE-LINE (STRCAT TX34",""K_DQ") FF) (WRITE-LINE (STRCAT TX35",""K_YQ") FF) (WRITE-LINE (STRCAT TX36",""K_YW") FF) (WRITE-LINE (STRCAT TX37",""K_WY") FF) (WRITE-LINE (STRCAT TX38",""K_ZS") FF) (WRITE-LINE (STRCAT TX39",""K_XS") FF) (WRITE-LINE (STRCAT TX40",""K_DZ") FF) ;;;标注制图(WRITE-LINE (STRCAT TX41",""K_SS") FF) (WRITE-LINE (STRCAT TX42",""K_QK") FF) (WRITE-LINE (STRCATTX43",""K_ER") FF) (WRITE-LINE (STRCAT TX44",""K_OO") FF) (WRITE-LINE (STRCAT TX45",""K_XX") FF) (WRITE-LINE (STRCAT TX46",""K_FF") FF) (WRITE-LINE (STRCAT TX47",""K_CC") FF) (WRITE-LINE (STRCAT TX48",""K_CII") FF) (WRITE-LINE (STRCAT TX49",""K_FL") FF) (WRITE-LINE (STRCAT TX50",""K_FC") FF) (WRITE-LINE (STRCATTX51",""K_EEE") FF) (WRITE-LINE (STRCAT TX52",""K_R2") FF) (WRITE-LINE (STRCAT TX53",""K_RC") FF) (WRITE-LINE (STRCAT TX55",""K_TT") FF) (WRITE-LINE (STRCAT TX56",""K_DF") FF) (WRITE-LINE (STRCATTX57",""K_JJ") FF) (WRITE-LINE (STRCAT TX58",""K_L J") FF) (WRITE-LINE (STRCAT TX59",""K_ZZ") FF) (WRITE-LINE (STRCAT TX60",""K_Z0") FF) ;;;专业制图(WRITE-LINE (STRCAT TX61",""K_YU") FF) (WRITE-LINE (STRCAT TX62",""K_DP") FF) (WRITE-LINE (STRCATTX63",""K_HH") FF) (WRITE-LINE (STRCAT TX64",""K_K0") FF) (WRITE-LINE (STRCAT TX65",""K_ZC") FF) (WRITE-LINE (STRCAT TX66",""K_ZD") FF) (WRITE-LINE (STRCAT TX67",""K_JM") FF) (WRITE-LINE (STRCAT TX68",""K_HF") FF) (WRITE-LINE (STRCAT TX69",""K_HFA") FF) (WRITE-LINE (STRCAT TX70",""K_HO") FF) (WRITE-LINE (STRCAT TX71",""K_YK") FF) (WRITE-LINE (STRCAT TX72",""K_FHM") FF) (WRITE-LINE (STRCAT TX73",""K_HFS") FF) (WRITE-LINE (STRCAT TX74",""K_CB") FF) (WRITE-LINE (STRCAT TX75",""K_CL") FF) (WRITE-LINE (STRCAT TX76",""K_DK") FF) (WRITE-LINE (STRCAT TX77",""K_TYC") FF) (WRITE-LINE (STRCAT TX78",""K_D4") FF) (WRITE-LINE (STRCAT TX79",""K_JC") FF) (WRITE-LINE (STRCAT TX80",""K_JT") FF);;;统计发布(WRITE-LINE (STRCAT TX81",""K_KI") FF) (WRITE-LINE (STRCAT TX82",""K_BW") FF) (WRITE-LINE (STRCATTX83",""K_RK") FF) (WRITE-LINE (STRCAT TX84",""K_KJ") FF) (WRITE-LINE (STRCAT TX85",""K_KS") FF) (WRITE-LINE (STRCAT TX86",""K_JK") FF) (WRITE-LINE (STRCAT TX87",""K_S2E") FF) (WRITE-LINE (STRCAT TX88",""K_XM") FF) (WRITE-LINE (STRCAT TX89",""K_JMM") FF) (WRITE-LINE (STRCAT TX90",""K_T2E") FF) (WRITE-LINE (STRCAT TX91",""K_TW") FF) (WRITE-LINE (STRCAT TX92",""K_MJE") FF) (WRITE-LINE (STRCAT TX93",""K_DDE") FF) (WRITE-LINE (STRCAT TX94",""K_WJY") FF)(WRITE-LINE (STRCAT TX96",""K_ORE") FF)(WRITE-LINE (STRCAT TX97",""K_RQ") FF)(WRITE-LINE (STRCAT TX98",""K_YM") FF)(WRITE-LINE (STRCAT TX99",""K_WK") FF)(WRITE-LINE (STRCAT TX100",""K_A3") FF)(CLOSE FF)(KKKKJ)(UNLOAD_DIALOG DCL_ID)(PRINC))(DEFUN KKKKJ(/ LST FFF TMP UI% XJ E1)(SETQ LST '())(IF(SETQ FFF(OPEN (G ETTOOLS P ATH)"R"))(PROGN(WHILE (SETQ TMP (READ-LINE FFF))(SETQ LST (CONS TMP LST)))(CLOSE FFF)))(SETQ UI%0)(REPEAT (LENGTH LST)(SETQ XJ (NTH UI%LST))(SETQ E1(VL-STRING-POSITION (ASCII ",")XJ))(SETQ B (SUBSTR XJ 1 E1))(SETQ A (SUBSTR XJ (+ E12)))(GKKJ)(SETQ UI%(+1 UI%))))(DEFUN GKKJ ()(EVAL(READ(STRCAT "(DEFUN C:"B"()(VLA-SENDCOMMAND (VLA-GET-ACTIVEDOCUMENT (VLAX-GET-ACAD-OBJECT))\"("A")\N\"))")))(PRINC))(KKKKJ)(DEFUN A CTION_F ORM1_K EYS (KEY / TXI%);全部控件的点击动作触发(COND((OR(= KEY "ACCEPT")(= KEY "CANCEL"))(G ET_F ORM1_D ATA)(SETQ TXI%1)(WHILE (< TXI%200)(SET (READ (STRCAT "TX"(ITOA TXI%)))(GET_TILE (STRCAT "T EXT"(ITOA TXI%))))(SETQ TXI%(+ TXI%1))) (DONE_DIALOG 1)))(PRINC))(DEFUN G ET_F ORM1_D ATA(/ KEY)(FOREACH KEY KEYS(SET (READ KEY )(GET_TILE KEY))));每个控件都赋给⼀个变量⽤于下次开启初始化(DEFUN W RITE_D CL_F ORM1(/D CL_F ILE FILE STR)(SETQ D CL_F ILE (VL-FILENAME-MKTEMP NIL NIL ".D CL"))(SETQ FILE (OPEN D CL_F ILE "W"))(FOREACH STR '("KK_BOX:EDIT_BOX { HEIGHT =0.1; HORIZONTAL_MARGIN = NONE ;VERTICAL_MARGIN = NONE ; WIDTH =0.1;}""F ORM1:DIALOG{LABEL =\"快捷键设置\";"":ROW{:BOXED_COLUMN { LABEL =\"图层显⽰\";"":KK_BOX{KEY =\"T EXT1\"; LABEL =\"框显图层\";}"":KK_BOX{KEY =\"T EXT2\"; LABEL =\"全显图层\";}"":KK_BOX{KEY =\"T EXT3\"; LABEL =\"凸显图层\";}"":KK_BOX{KEY =\"T EXT4\"; LABEL =\"框隐图层\";}"":KK_BOX{KEY =\"T EXT5\"; LABEL =\"锁定图层\";}"":KK_BOX{KEY =\"T EXT7\"; LABEL =\"按⾊归层\";}" ":KK_BOX{KEY =\"T EXT8\";LABEL =\"调当前层\";}" ":KK_BOX{KEY =\"T EXT9\";LABEL =\"按⾊显⽰\";}" ":KK_BOX{KEY =\"T EXT10\";LABEL =\"按⾊隐藏\";}" ":KK_BOX{KEY =\"TEXT11\";LABEL =\"按⾊选择\";}" ":KK_BOX{KEY =\"T EXT12\";LABEL =\"框显图元\";}" ":KK_BOX{KEY =\"T EXT13\";LABEL =\"框隐图元\";}" ":KK_BOX{KEY =\"T EXT14\";LABEL =\"全显图元\";}" ":KK_BOX{KEY =\"T EXT15\";LABEL =\"筛选块名\";}" ":KK_BOX{KEY =\"T EXT16\";LABEL =\"筛选属性\";}" ":KK_BOX{KEY =\"T EXT17\";LABEL =\"图层改⾊\";}" ":KK_BOX{KEY =\"T EXT18\"; LABEL =\"刷中线层\";}" ":KK_BOX{KEY =\"T EXT19\"; LABEL =\"刷虚线层\";}" ":KK_BOX{KEY =\"TEXT20\";LABEL =\"刷当前层\";}}" ":BOXED_COLUMN{ LABEL =\"⽂本属性\";"":KK_BOX{KEY =\"T EXT21\";LABEL =\"字转属性\";}" ":KK_BOX{KEY =\"T EXT22\";LABEL =\"属性转字\";}" ":KK_BOX{KEY =\"T EXT23\";LABEL =\"超强复制\";}" ":KK_BOX{KEY =\"T EXT24\";LABEL =\"增序替换\";}" ":KK_BOX{KEY =\"TEXT25\";LABEL =\"加⼀复制\";}" ":KK_BOX{KEY =\"T EXT26\";LABEL =\"⽂字⾼度\";}" ":KK_BOX{KEY =\"T EXT27\";LABEL =\"⽂字排版\";}" ":KK_BOX{KEY =\"T EXT28\";LABEL =\"⽂字左齐\";}" ":KK_BOX{KEY =\"T EXT29\";LABEL =\"⽂字右齐\";}" ":KK_BOX{KEY =\"T EXT30\";LABEL =\"⽂字底齐\";}" ":KK_BOX{KEY =\"T EXT31\";LABEL =\"⽂字线齐\";}" ":KK_BOX{KEY =\"T EXT32\";LABEL =\"⽂字查找\";}" ":KK_BOX{KEY =\"T EXT33\";LABEL =\"批改⽂字\";}" ":KK_BOX{KEY =\"TEXT34\";LABEL =\"标注对齐\";}" ":KK_BOX{KEY =\"T EXT35\";LABEL =\"引线对齐\";}" ":KK_BOX{KEY =\"T EXT36\";LABEL =\"引线字中\";}" ":KK_BOX{KEY =\"T EXT37\";LABEL =\"引线字上\";}" ":KK_BOX{KEY =\"T EXT38\";LABEL =\"中线⽐例\";}" ":KK_BOX{KEY =\"T EXT39\";LABEL =\"虚线⽐例\";}" ":KK_BOX{KEY =\"T EXT40\";LABEL =\"标注原值\";}}"":BOXED_COLUMN{ LABEL =\"标准制图\";"":KK_BOX{KEY =\"T EXT41\"; LABEL =\"默认设置\";}" ":KK_BOX{KEY =\"T EXT42\"; LABEL =\"清空零线\";}" ":KK_BOX{KEY =\"T EXT43\";LABEL =\"分类删除\";}" ":KK_BOX{KEY =\"T EXT44\";LABEL =\"双偏保中\";}" ":KK_BOX{KEY =\"TEXT45\";LABEL =\"双偏删中\";}" ":KK_BOX{KEY =\"T EXT46\";LABEL =\"多重圆⾓\";}" ":KK_BOX{KEY =\"T EXT47\";LABEL =\"定距复制\";}"":KK_BOX{KEY =\"T EXT49\";LABEL =\"分类选择\";}"":KK_BOX{KEY =\"T EXT50\";LABEL =\"分层选择\";}"":KK_BOX{KEY =\"T EXT51\";LABEL =\"删重叠线\";}"":KK_BOX{KEY =\"T EXT52\";LABEL =\"旋转对齐\";}"":KK_BOX{KEY =\"T EXT53\";LABEL =\"旋转复制\";}"":KK_BOX{KEY =\"T EXT54\";LABEL =\"偏块内线\";}"":KK_BOX{KEY =\"T EXT55\";LABEL =\"边界剪切\";}"":KK_BOX{KEY =\"T EXT56\";LABEL =\"线元等分\";}"":KK_BOX{KEY =\"T EXT57\";LABEL =\"框选合线\";}"":KK_BOX{KEY =\"T EXT58\";LABEL =\"框选连线\";}"":KK_BOX{KEY =\"T EXT59\";LABEL =\"图元归零\";}"":KK_BOX{KEY =\"T EXT60\";LABEL =\"归零慎⽤\";}}"":BOXED_COLUMN{ LABEL =\"专业制图\";"":KK_BOX{KEY =\"T EXT61\";LABEL =\"修改云线\";}"":KK_BOX{KEY =\"T EXT62\";LABEL =\"矩形介⼦\";}"":KK_BOX{KEY =\"T EXT63\";LABEL =\"两点填充\";}"":KK_BOX{KEY =\"T EXT64\";LABEL =\"块内零层\";}"":KK_BOX{KEY =\"T EXT65\";LABEL =\"圆折断线\";}"":KK_BOX{KEY =\"T EXT66\";LABEL =\"折断线__\";}"":KK_BOX{KEY =\"T EXT67\";LABEL =\"铝⾓码码\";}"":KK_BOX{KEY =\"T EXT68\";LABEL =\"直焊缝__\";}"":KK_BOX{KEY =\"T EXT69\";LABEL =\"圆焊缝__\";}"":KK_BOX{KEY =\"T EXT70\";LABEL =\"剖圆孔__\";}"":KK_BOX{KEY =\"T EXT71\";LABEL =\"长圆孔__\";}"":KK_BOX{KEY =\"T EXT72\";LABEL =\"保温棉__\";}"":KK_BOX{KEY =\"T EXT73\";LABEL =\"⾓焊缝__\";}"":KK_BOX{KEY =\"T EXT74\";LABEL =\"偏移⼦段\";}"":KK_BOX{KEY =\"T EXT75\";LABEL =\"槽铝断⾯\";}"":KK_BOX{KEY =\"T EXT76\";LABEL =\"硬质垫块\";}"":KK_BOX{KEY =\"T EXT77\";LABEL =\"椭圆圆弧\";}"":KK_BOX{KEY =\"T EXT78\";LABEL =\"四点尖⾓\";}"":KK_BOX{KEY =\"T EXT79\";LABEL =\"⾓钢槽钢\";}"":KK_BOX{KEY =\"T EXT80\";LABEL =\"⽅钢⼯钢\";}}"":BOXED_COLUMN{ LABEL =\"统计发布\";"":KK_BOX{KEY =\"T EXT81\";LABEL =\"快速建块\";}"":KK_BOX{KEY =\"T EXT82\";LABEL =\"炸块成字\";}"":KK_BOX{KEY =\"T EXT83\";LABEL =\"图块改名\";}"":KK_BOX{KEY =\"T EXT84\";LABEL =\"图块基点\";}"":KK_BOX{KEY =\"T EXT85\";LABEL =\"图块改⾊\";}"":KK_BOX{KEY =\"T EXT86\";LABEL =\"交点布块\";}"":KK_BOX{KEY =\"T EXT87\";LABEL =\"属块导表\";}"":KK_BOX{KEY =\"T EXT88\";LABEL =\"线密度__\";}"":KK_BOX{KEY =\"T EXT89\";LABEL =\"截⾯参数\";}"":KK_BOX{KEY =\"T EXT90\";LABEL =\"排字到表\";}"":KK_BOX{KEY =\"T EXT91\";LABEL =\"统字到表\";}"":KK_BOX{KEY =\"T EXT92\";LABEL =\"⾯积到表\";}"":KK_BOX{KEY =\"T EXT93\";LABEL =\"线长到表\";}"":KK_BOX{KEY =\"T EXT94\";LABEL =\"外接圆形\";}"":KK_BOX{KEY =\"T EXT95\";LABEL =\"外接矩形\";}"":KK_BOX{KEY =\"T EXT96\";LABEL =\"图元加框\";}"":KK_BOX{KEY =\"T EXT97\";LABEL =\"画图⽇期\";}"":KK_BOX{KEY =\"T EXT98\";LABEL =\"批改页码\";}"":KK_BOX{KEY =\"T EXT99\";LABEL =\"批量分图\";}"":KK_BOX{KEY =\"T EXT100\";LABEL =\"批量打印\";}}}"":ROW{:TEXT{LABEL=\"命令⽂件位置C:/W INDOWS/K_COM.TXT，删除后相当于初始设置\\";ALIGNMENT=LEFT;}SPACER_1;SPACER_1;SPACER_1; OK_BUTTON;CANCEL_BUTTON;}} ")(WRITE-LINE STR FILE))(CLOSE FILE)D CL_F ILE)(KKKKJ);恢复默认设置命令(DEFUN K_KMR(/ TMP)(IF (FINDFILE(G ETTOOLS P ATH))(VL-FILE-DELETE (G ETTOOLS P ATH)))(KKKKJ)(PRINC));清空命令(DEFUN K_KQK(/ FF)(IF (FINDFILE(G ETTOOLS P ATH))(PROGN (SETQ FF(OPEN (G ETTOOLS P ATH)"W"));;;图层显⽰(WRITE-LINE (STRCAT ",""K_LL") FF)(WRITE-LINE (STRCAT ",""K_LK") FF)(WRITE-LINE (STRCAT ",""K_LP") FF)(WRITE-LINE (STRCAT ",""K_LY") FF)(WRITE-LINE (STRCAT ",""K_LO") FF)(WRITE-LINE (STRCAT ",""K_LU") FF)(WRITE-LINE (STRCAT ",""K_ACC") FF)(WRITE-LINE (STRCAT ",""K_L0") FF)(WRITE-LINE (STRCAT ",""K_CV") FF)(WRITE-LINE (STRCAT ",""K_CY") FF)(WRITE-LINE (STRCAT ",""K_CD") FF)(WRITE-LINE (STRCAT ",""K_VH") FF) (WRITE-LINE (STRCAT ",""K_VA") FF) (WRITE-LINE (STRCAT ",""K_KM") FF) (WRITE-LINE (STRCAT ",""K_FS") FF) (WRITE-LINE (STRCAT ",""K_LC") FF) (WRITE-LINE (STRCAT ",""K_SZC") FF) (WRITE-LINE (STRCAT ",""K_SXC") FF) (WRITE-LINE (STRCAT ",""K_SDC") FF);;;⽂本属性(WRITE-LINE (STRCAT ",""K_W2A") FF) (WRITE-LINE (STRCAT ",""K_A2W") FF) (WRITE-LINE (STRCAT ",""K_CA") FF) (WRITE-LINE (STRCAT ",""K_ZX") FF) (WRITE-LINE (STRCAT ",""K_C1") FF) (WRITE-LINE (STRCAT ",""K_WHH") FF) (WRITE-LINE (STRCAT ",""K_WW") FF) (WRITE-LINE (STRCAT ",""K_WEE") FF) (WRITE-LINE (STRCAT ",""K_WQQ") FF) (WRITE-LINE (STRCAT ",""K_WX") FF) (WRITE-LINE (STRCAT ",""K_WA") FF) (WRITE-LINE (STRCAT ",""K_FW") FF) (WRITE-LINE (STRCAT ",""K_WWS") FF) (WRITE-LINE (STRCAT ",""K_DQ") FF) (WRITE-LINE (STRCAT ",""K_YQ") FF) (WRITE-LINE (STRCAT ",""K_YW") FF) (WRITE-LINE (STRCAT ",""K_WY") FF) (WRITE-LINE (STRCAT ",""K_ZS") FF) (WRITE-LINE (STRCAT ",""K_XS") FF) (WRITE-LINE (STRCAT ",""K_DZ") FF) ;;;标注制图(WRITE-LINE (STRCAT ",""K_SS") FF) (WRITE-LINE (STRCAT ",""K_QK") FF) (WRITE-LINE (STRCAT ",""K_ER") FF) (WRITE-LINE (STRCAT ",""K_OO") FF) (WRITE-LINE (STRCAT ",""K_XX") FF) (WRITE-LINE (STRCAT ",""K_FF") FF) (WRITE-LINE (STRCAT ",""K_CC") FF) (WRITE-LINE (STRCAT ",""K_CII") FF) (WRITE-LINE (STRCAT ",""K_FL") FF) (WRITE-LINE (STRCAT ",""K_FC") FF) (WRITE-LINE (STRCAT ",""K_EEE") FF) (WRITE-LINE (STRCAT ",""K_R2") FF) (WRITE-LINE (STRCAT ",""K_KL") FF) (WRITE-LINE (STRCAT ",""K_TT") FF) (WRITE-LINE (STRCAT ",""K_DF") FF) (WRITE-LINE (STRCAT ",""K_JJ") FF) (WRITE-LINE (STRCAT ",""K_L J") FF) (WRITE-LINE (STRCAT ",""K_ZZ") FF) (WRITE-LINE (STRCAT ",""K_Z0") FF) ;;;专业制图(WRITE-LINE (STRCAT ",""K_YU") FF) (WRITE-LINE (STRCAT ",""K_DP") FF) (WRITE-LINE (STRCAT ",""K_HH") FF) (WRITE-LINE (STRCAT ",""K_K0") FF) (WRITE-LINE (STRCAT ",""K_ZC") FF) (WRITE-LINE (STRCAT ",""K_ZD") FF) (WRITE-LINE (STRCAT ",""K_JM") FF) (WRITE-LINE (STRCAT ",""K_HF") FF) (WRITE-LINE (STRCAT ",""K_HFA") FF) (WRITE-LINE (STRCAT ",""K_HO") FF) (WRITE-LINE (STRCAT ",""K_YK") FF) (WRITE-LINE (STRCAT ",""K_FHM") FF) (WRITE-LINE (STRCAT ",""K_HFS") FF) (WRITE-LINE (STRCAT ",""K_CB") FF) (WRITE-LINE (STRCAT ",""K_CL") FF) (WRITE-LINE (STRCAT ",""K_DK") FF) (WRITE-LINE (STRCAT ",""K_TYC") FF) (WRITE-LINE (STRCAT ",""K_D4") FF) (WRITE-LINE (STRCAT ",""K_JC") FF) (WRITE-LINE (STRCAT ",""K_JT") FF) ;;;统计发布(WRITE-LINE (STRCAT ",""K_KI") FF) (WRITE-LINE (STRCAT ",""K_BW") FF) (WRITE-LINE (STRCAT ",""K_RK") FF) (WRITE-LINE (STRCAT ",""K_KJ") FF) (WRITE-LINE (STRCAT ",""K_KS") FF) (WRITE-LINE (STRCAT ",""K_JK") FF) (WRITE-LINE (STRCAT ",""K_S2E") FF) (WRITE-LINE (STRCAT ",""K_XM") FF) (WRITE-LINE (STRCAT ",""K_JMM") FF) (WRITE-LINE (STRCAT ",""K_T2E") FF) (WRITE-LINE (STRCAT ",""K_TW") FF) (WRITE-LINE (STRCAT ",""K_MJE") FF) (WRITE-LINE (STRCAT ",""K_DDE") FF) (WRITE-LINE (STRCAT ",""K_WJY") FF)(WRITE-LINE (STRCAT ",""K_ORE") FF)(WRITE-LINE (STRCAT ",""K_RQ") FF)。
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格式。
AutoLISP语言编制AutoCAD实用程序
些 小 程 序 段 串 联 起 来 实 现 界 面 化 与 系 统
ｐ
化
Ｐ Ｃ
Ｐ ｌ
ｐ ３
／
ｆ
中 国科教创新 导刊
Ｃ ｉ ｄ ｃ ｔ ｎ Ｉｎ ｖ ｔ ｎ Ｈ ｒ ｌ ｈ ａ Ｅ ｕ ａ ｉ ｎｏ ａ ｉ ｅａｄ ｎ ｏ ｏ
１９ ６
（ ｅ ｑ Ｐ８ （ Ｏｌ Ｐ７ ４ １ ６） ｓｔ Ｐ ａ ｒ ． ）
（ｏ ｃ ｍｍａ ｄ ” ｌ ｅ ｎ ｐ ｉ ”ｐ ” ｎ ３ ｈ” ０ ２ ０ ２ Ｐ１ ． ．
行 修 改 和扩 充 。 Ａ ｔ ＣＡＤ 台上 进 行应 言 编 制 基 准 标 注 的 参 数 化 绘 图 的 程 序 。 在 ｕｏ 平 通 根据 基准 点给 Ｐ 参 数 赋 值 ５ 过 实例 来 分析 Ａｕ ｏ Ｉ Ｐ 序 语言 的 程序 结 ｔＬ Ｓ 程
标 注应 用 的要 求 。 用 Ｌ ＳＰ语 言 可 以 方 便 利 Ｉ 地调 用 Ａｕ ｏ ｔ ＣＡＤ的 绘 图命 令 ， 使设 计 和 绘 接 访 问 、 改 ， 现 对 屏 幕 图 形 的 实 时 修 修 实
（ ｍ ｎ ” ｒ ｅ ｐ ） ｃ ｍａ ｄ ｃ ｃ ” ７ ３ ｏ ｉｌ
圆命 令 绘 制 圆弧 半 径 为 ３ 心 为Ｐ７ 圆
（ ｅ ｑ Ｐ３ （ １ Ｐ１ ａ ３ ） Ｓｔ Ｐ０ ａｒ ）
最基 本 的数 据类 型是 符 号表 达 式 （ｙ ｏｉ Ｓ ｍｂ ｌ 根 据 基 准 点 给 Ｐ 参 数 赋 值 ｃ ３
（ｅ ｑ ４ （ ｏ ａ Ｐ１ （ ａ ｉ ３ ） ｓｔ ｐ ｐ ｌｒ ＋ ｐ ） ） 参 户编 写 的 函 数 ， 实现 命 令 的 扩 展 与 增加 。 下 根据 基 准 点 给Ｐ４ 数 赋值
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
一个在CADxx标注坐标的LISP使用方法：先把下面的代码复制,再打开CAD,工具-AutoLIST-VISUAL LISP编辑器-新建-粘贴-保存-退出再之就工具-AutoLIST-加载应用程序,找到你保存的那个东东,加载,关闭退出,输入ZBBZ就可以啦!!!!![复制到剪切板][ - ]代码:(defun C:zbbz( / zb gd cld osm )(setq osm (getvar"osmode"))(setvar "osmode" 33)(setq gd (getreal "指定标注文字高度:>"))(if (= gd nil) (setq gd0.5))(while (setq zb (getpoint "指定坐标点："))(setq cld(getpoint zb "指定文字插入点："))(entmake (list'(0 . "LINE")'(67 . 0)'(8 . "0")(list 10 (car zb) (cadr zb) 0)(list 11 (car cld) (cadr cld) 0)'(2100.00.01.0)))(entmake (list'(0 . "text")(list 10 (+ (car cld) gd) (car(cdr cld)) ) (cons 40 gd)(cons 1 ( strcat "X=" (rtos (cadr zb) 2 3))) '(50 . 0)))(entmake (list'(0 . "text")(list 10 (+ (car cld) gd)(- (car(cdr cld)) (+ gd (/ gd 3)) ))(cons 40 gd) (cons 1 (strcat "Y="(rtos (car zb) 2 3)))'(50 . 0))0G&B4v$L.r5o3_))(setvar "osmode" osm) (princ))。
几个有用的CAD的加载程序LISP
几个有用的CAD的加载程序LISP几个有用的CAD的加载程序LISP (2013-01-10 18:58:27)转载▼标签： cad加载程序杂谈分类： CAD应用1.图层命令;;; -----------------------------------------------------------------;;; 2 图层命令;;; ------------------------------------------------------------------;;; 2.1 LayerOff 关闭物体所在的层（单选）(defun c:1 (/ ent lname)(setvar "cmdecho" 0)(setq ent (entsel "\nPick an entity on the target layer: "))(if ent(progn(setq ent (entget (car ent)))(setq lname (cdr (assoc 8 ent))))(setq lname (getstring "\nNot to selected, Input layer name: ")))(if (= (getvar "clayer") lname)(setvar "clayer" "0"))(command "layer" "off" lname "")(princ));;; 2.2 LayerOffM 关闭物体所在的层（多选）(Defun C:LayerOffM ()(setvar "cmdecho" 0)(prompt "\nSelect entities to turn off:") (setq ss (ssget))(if (andss(sslength ss))(progn(setq ct 0len (sslength ss)cl (getvar "clayer"))(command ".layer")(while (< ct len)(setq la (cdr (assoc 8 (entget (ssname ss ct))))) (if (/= cl la)(command "off" la)(progn(prompt "\nThe layer")(prompt la)(prompt "is CURRENT!")))(if (= old nil)(setq OLD la)(setq OLD (strcat OLD "," la)))(setq ct (1+ ct)))(command "")))(princ)(setvar "cmdecho" 0)(prin1));;; 2.3 LayerOffOther 关闭物体以外的层(defun c:LayerOffOther (/ ent lname)(setvar "cmdecho" 0)(setq ent (entsel "\nPick an entity on the target layer: ")) (if ent(progn(setq ent (entget (car ent)))(setq lname (cdr (assoc 8 ent)))(setvar "clayer" lname)))(command "layer" "off" "*" "n" "")(princ));;; 2.3.1 LayerOffOtherM 关闭物体以外的层（多选）(Defun C:2 (/ ss ct cl la old)(setvar "cmdecho" 0)(prompt "\nSelect entities on the layers you want to remain:") (setq ss (ssget))(setq ct 0len (sslength ss)cl (cdr (assoc 8 (entget (ssname ss 0)))))(setvar "clayer" cl)(while (< ct len)(setq la (cdr (assoc 8 (entget (ssname ss ct)))))(if (= old nil)(setq OLD la)(setq OLD (strcat OLD "," la)))(setq ct (1+ ct)))(command ".layer" "off" "*" "n" "")(command ".layer" "on" old "")(princ));;; ------------------------------------------------------------------;;; 2.4 LayerLockM 锁住物体所在的层（多选）(defun C:4 (/ ES EN EL A)(princ "Selected Entity(s) Layers Locked.")(setq ES (ssget)A 0EN ""EL nilFL nil)(while (/= EN nil)(setq EN (ssname ES A)EL (cons EN EL)A (1+ A)))(setq EL (cdr EL)FL (cdr (assoc '8 (entget (car EL))))EL (cdr EL))(repeat (- A 2)(setq EN (cdr (assoc '8 (entget (car EL))))FL (strcat EN "," FL)EL (cdr EL)))(command "LAYER" "LO" (eval FL) "") (princ));;; 2.5 LayerUnlockM 解锁物体所在的层（多选）(defun C:5 (/ ES EN EL A)(princ "Selected Entity(s) Layers Unlocked.") (setq ES (ssget)A 0EN ""EL nilFL nil)(while (/= EN nil)(setq EN (ssname ES A)EL (cons EN EL)A (1+ A)))(setq EL (cdr EL)FL (cdr (assoc '8 (entget (car EL)))))(repeat (- A 2)(setq EN (cdr (assoc '8 (entget (car EL))))FL (strcat EN "," FL)EL (cdr EL)))(command "LAYER" "U" (eval FL) "")(princ));;; ------------------------------------------------------------------;;; 2.6 LayerFreezeM 冻结物体所在的层（多选）(defun C:LayerFreezeM (/ ES EN EL A)(princ "Selected Entity(s) Layers Freezed.")(setq ES (ssget)A 0EN ""EL nilFL nil)(while (/= EN nil)(setq EN (ssname ES A)EL (cons EN EL)A (1+ A)))(setq EL (cdr EL)FL (cdr (assoc '8 (entget (car EL)))))(repeat (- A 2)(setq EN (cdr (assoc '8 (entget (car EL))))FL (strcat EN "," FL)EL (cdr EL)))(command "LAYER" "F" (eval FL) "")(princ));;; 2.7 LayerThawAll 解冻所有的层(Defun C:LayerThawAll ()(COMMAND "LAYER" "THAW" "*" "")(PRINC));;; ------------------------------------------------------------------;;; 2.8 LayerCurrent 将物体所在的层设为当前层(defun c:LayerCurrent (/ ent lname)(setvar "cmdecho" 0)(setq ent (car (entsel "\nPick an entity on the target layer: "))) (if ent(progn(setq ent (entget ent)lname (cdr (assoc 8 ent))))(progn(setq lname (getstring "\nNot to selected, Input layer name:))(setvar "clayer" lname)(princ));;; ------------------------------------------------------------------;;; 2.9 LayerOnAll 打开所有层(Defun C:3 ()(command "layer" "on" "*" "")(princ));;; ------------------------------------------------------------------;;; 2.10 ToCurrentLayerM 将物体转到当前层（多选），并使用层颜色，线型(defun c:T oCurrentLayerM (/ lname ss)(setq ss (ssget))(if ss(progn(setq lname (getvar "clayer"))(command "chprop" ss "" "la" lname "color" "bylayer" "ltype" "bylayer"""))));;; ----------------------------------------------------------------;;; 2.11 ToLayerMatch 通过目标物体改变选择实体的图层属性(defun c:T oLayerMatch (/ lname ss ent)(setvar "cmdecho" 0)(prompt "\nSelect the entity(s): ")(setq ss (ssget))(if ss(progn(setq ent (entsel "\nPick an entity on the target layer: "))(if ent(progn(setq ent (entget (car ent)))(setq lname (cdr (assoc 8 ent))))(progn(setq lname (getstring "\nNot to selected, Input layer name: "))))(command "chprop" ss "" "la" lname "")))(princ))快捷键1-掩藏图层快捷键2-只显示选中图层快捷键3-显示全部图层0000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000002.增强复制;;;********************************************************图形矫正程序-jz(defun c:cc (/ p1 p2 s e cn);__________________(defun ttt (ss n / m)(setq ee ens (ssadd))(while (setq ee (entnext ee))(setq ns (ssadd ee ns)))(command "erase" ns "")(command "copy" ss "" "m" "non" p1)(setq m 0)(repeat (atoi n)(setq m (1+ m))(cond((= "/" (substr n (strlen n)))(command"non"(mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n)))))p1p2)))(t(command "non"(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2)))))(command));__________________(princ "\n选择要复制的物体:")(setq s (ssget))(setq p1 (getpoint "\n复制的起点:"))(setq p2 (getpoint p1 "\n复制的终点:"))(setq e (entlast))(command "copy" s "" "non" p1 "non" p2) (while (/= 0(atof (setq cn (getstring "\n份数(以 / 结束为等分):"))) )(ttt s cn))(princ))(defun c:c1 (/ p1 p2 s e cn a1 d1 ns cnn);__________________(defun ttt (ss n / m)(setq ee ens (ssadd))(while (setq ee (entnext ee))(setq ns (ssadd ee ns)))(command "erase" ns "")(command "copy" ss "" "m" "non" p1)(if (member (substr n (strlen n)) '("/" "*")) (progn(setq m 0)(repeat (atoi n)(setq m (1+ m))(cond((= "/" (substr n (strlen n)))(command"non"(mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n))))) p1p2)))((= "*" (substr n (strlen n)))(command "non"(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2))))))(command "non" (setq p2 (polar p1 a1 (atof n)))) )(command));__________________(princ "\n选择要复制的物体:")(setq s (ssget))(setq p1 (getpoint "\n复制的起点:"))(command "undo" "be" "line" p1 p1 "")(setq e (entlast))(command "copy" s "" "non" p1 pause)(setq p2 (getvar "lastpoint")a1 (angle p1 p2)d1 (distance p1 p2))(setq cn "1*")(while cn(ttt s cn)(initget 128)(princ"\n输入坐标=复制终点输入数值=修改间距 ")(princ"\n输入数值n并以 / 结束=间距内等分n次复制输入数值n并以 * 结束=按间距复制n次 ")(setq cnn (getpoint "\n请按提示输入<退出>:"))(if (= 'LIST (type cnn))(setq p2 cnna1 (angle p1 p2)d1 (distance p1 p2))(setq cn cnn)))(entdel e)(command "undo" "e")(princ))(defun c:c2 (/ p1 p2 s e cn);__________________(defun ttt (ss n / m)(setq ee ens (ssadd))(while (setq ee (entnext ee))(setq ns (ssadd ee ns)))(command "erase" ns "")(command "copy" ss "" "m" "non" p1)(setq m 0)(repeat (atoi n)(setq m (1+ m))(cond((= "/" (substr n (strlen n)))(command"non"(mapcar '(lambda (x y) (+ x (* m (/ (- y x) (atof n))))) p1p2)))(t(command "non"(mapcar '(lambda (x y) (+ x (* m (- y x)))) p1 p2))))(command));__________________(princ "\n选择要复制的物体:")(setq s (ssget))(setq p1 (getpoint "\n复制的起点:"))(setvar "lastpoint" p1);(setq p2 (getpoint p1 "\n复制的终点:"))(setq e (entlast))(command "copy" s "" "non" p1 pause)(if (not (equal p1 (setq p2 (getvar "lastpoint")))) (while (/= 0(atof (setq cn (getstring "\n份数(以 / 结束为等分):"))) )(ttt s cn)))(princ));;;|增强拷贝(defun c:c3 (/ getpt getpt1 ss ptx pty db n x y gtin) (setq getpt1 (acet-ss-drag-move(setq ss (ssget))(setq getpt (getpoint "\n&点取基点:"))1)(setq ptx (- (car getpt1) (car getpt))pty (- (cadr getpt1) (cadr getpt))y 0)(vl-cmdf ".copy" ss "" getpt getpt1) (while (setq gtin (- (getint "\n重复次数:") 1)) (vl-cmdf ".undo" "e")(if (/= y 0)(vl-cmdf ".u"))(setq n 1x 0db nil)(if (/= y 0)(vl-cmdf ".u"))(vl-cmdf ".undo" "be")(repeat gtin(setq db (cons (list (+ (* n ptx) (car getpt1)) (+ (* n pty) (cadr getpt1))0.0)db))(setq n (1+ n)))(repeat (length db)(vl-cmdf ".copy" ss "" getpt (nth x (reverse db)))(setq x (1+ x)))(vl-cmdf ".undo" "e")(vl-cmdf ".undo" "be")(setq y (1+ y)))(princ))快捷键C1-等分复制快捷键C2-多重复制0000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000003.墙柱工具无敌（雨夜屠夫）VLX文件，自己上网搜索。
CAD lisp 实用小程序(源代码)
CAD lisp实用小程序（源代码）一、圆自动同心(defun c:TX(/qi aa ec center v_c)(vl-load-com)(princ"圆自动同心:")(setq aa(ssget));;获取圆的图元名(setq center(getpoint"选取点位置："));(setq center(vlax-3D-point center));(setq qi0);初始序号(repeat(sslength aa);对象个数(setq ec(ssname aa qi));选择第一个图元(setq v_c(vlax-ename->vla-object ec));将圆的图元名转换为VLA对象(vla-put-center v_c center);更新圆中心点(setq qi(+qi1)));repeat(princ"修改成功:"));defun二、图层快速修改(princ"快速修改图层编程-TC")(defun C:TC(/)(vl-load-com)(setq SET_ZJTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择基准图层:"))))) (WHILE(NOT SET_ZJTC)(setq SET_ZJTC(vla-get-Layer(vlax-ename->vla-object(car(entsel "\n基准图层为空，重新选择！:"))))))(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择修改图层:"))))) (WHILE(NOT SET_XGTC)(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car (entsel"\n修改图层为空，重新选择！:"))))))(vlax-for VLA_MSP(vla-get-ModelSpace(vla-get-ActiveDocument(vlax-get-Acad-Object))) (IF(=(vla-get-Layer VLA_MSP)SET_XGTC)(vla-put-Layer VLA_MSP SET_ZJTC))) (princ"\n快速修改图层编程-TC:")(princ));DEFUN三、字高自动修改(princ"快速修改字高编程-ZG")(defun C:ZG(/)(vl-load-com)(setq SET_ZTGD(vla-get-Height(vlax-ename->vla-object(car(entsel"\n选择基准字高:"))))) (WHILE(NOT SET_ZJTC)(setq SET_ZJTC(vla-get-Height(vlax-ename->vla-object(car (entsel"\n基准字高为空，重新选择！:"))))))(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择修改图层:"))))) (WHILE(NOT SET_XGTC)(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car (entsel"\n修改图层为空，重新选择！:"))))))(vlax-for VLA_MSP(vla-get-ModelSpace(vla-get-ActiveDocument(vlax-get-Acad-Object))) (IF(=(vla-get-Layer VLA_MSP)SET_XGTC)(vla-put-Height VLA_MSP SET_ZTGD))) (princ"\n快速修改图层编程-ZG")(princ));DEFUN。
CAD画缓和曲线lisp程序
C A D画缓和曲线l i s p程序(总3页)-CAL-FENGHAI.-(YICAI)-Company One1-CAL-本页仅作为文档封面，使用请直接删除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。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
CAD lisp实用小程序（源代码）
一、圆自动同心
(defun c:TX(/qi aa ec center v_c)
(vl-load-com)
(princ"圆自动同心:")
(setq aa(ssget));;获取圆的图元名
(setq center(getpoint"选取点位置："));
(setq center(vlax-3D-point center));
(setq qi0);初始序号
(repeat(sslength aa);对象个数
(setq ec(ssname aa qi));选择第一个图元
(setq v_c(vlax-ename->vla-object ec));将圆的图元名转换为VLA对象
(vla-put-center v_c center);更新圆中心点
(setq qi(+qi1))
);repeat
(princ"修改成功:")
);defun
二、图层快速修改
(princ"快速修改图层编程-TC")
(defun C:TC(/)
(vl-load-com)
(setq SET_ZJTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择基准图层:"))))) (WHILE(NOT SET_ZJTC)(setq SET_ZJTC(vla-get-Layer(vlax-ename->vla-object(car(entsel "\n基准图层为空，重新选择！:"))))))
(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择修改图层:"))))) (WHILE(NOT SET_XGTC)(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car (entsel"\n修改图层为空，重新选择！:"))))))
(vlax-for VLA_MSP(vla-get-ModelSpace(vla-get-ActiveDocument(vlax-get-Acad-Object))) (IF(=(vla-get-Layer VLA_MSP)SET_XGTC)(vla-put-Layer VLA_MSP SET_ZJTC))) (princ"\n快速修改图层编程-TC:")
(princ)
);DEFUN
三、字高自动修改
(princ"快速修改字高编程-ZG")
(defun C:ZG(/)
(vl-load-com)
(setq SET_ZTGD(vla-get-Height(vlax-ename->vla-object(car(entsel"\n选择基准字高:"))))) (WHILE(NOT SET_ZJTC)(setq SET_ZJTC(vla-get-Height(vlax-ename->vla-object(car (entsel"\n基准字高为空，重新选择！:"))))))
(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car(entsel"\n选择修改图层:"))))) (WHILE(NOT SET_XGTC)(setq SET_XGTC(vla-get-Layer(vlax-ename->vla-object(car (entsel"\n修改图层为空，重新选择！:"))))))
(vlax-for VLA_MSP(vla-get-ModelSpace(vla-get-ActiveDocument(vlax-get-Acad-Object))) (IF(=(vla-get-Layer VLA_MSP)SET_XGTC)(vla-put-Height VLA_MSP SET_ZTGD))) (princ"\n快速修改图层编程-ZG")
(princ)
);DEFUN。