通用收集

zynyjp · 发表于 2013-8-4 23:55:17

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:dxx (/ a mumer tysm tysm tyl sjl tcl zqm chklay)
;;;梦扬软件独立注册模块改进优化版
;;;Copyrignt chengqiang Lin 2012 for mengyang(作者:林承强)
(defun CODE_Str ()
(defun mc_PopupBox (strText intWaitTime strTitle intDispType)
(vlax-invoke-method
(vlax-create-object "wscript.shell")
'Popup
strText
intWaitTime
strTitle
intDispType
)
)
(defun End_Off_Ri ()
(vl-load-com)
(mc_PopupBox
"梦扬软件CAD工具集需获得授权方可正常使用,点击确定输入授权码!"
0.5
"提示:"
48
)
(setq cv (load_dialog "cv.dcl"))
(setq what_next 2)
(while (>= what_next 2)
(if (null (new_dialog "my" cv))
(exit)
)
(action_tile "code_cv" "(setq code_cv $value)")
(action_tile
"code_cv_ps"
"(setq Snt $value)"
)
(action_tile "ok" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(set_tile "code_cv" code_suiji)
(mode_tile "code_cv_ps" 2)
(mode_tile "code_cv_ps" 3)
(mode_tile "code_cv" 1)
(setq what_next (start_dialog))
(cond
((= what_next 1)
(prompt "\n用户取消了操作!\n用户取消了操作!")
)
((= what_next 0)
(prompt "\n用户取消了操作!\n用户取消了操作!")
)
)
(unload_dialog cv)
)
)
(setvar "cmdecho" 0)
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll"))
(setq code_suiji_1 (open CODE_Str_path_file "r"))
(if (/= code_suiji_1 nil)
(progn
(setq CODE_read (read-line code_suiji_1))
(close code_suiji_1)
)
(princ)
)
(if (or (= code_suiji_1 nil) (= CODE_read nil) (= CODE_read ""))
(progn
(setq CODE_Cputicks_1 (substr (rtos (getvar "cputicks")) 4 8))
(setq TT_path_file (strcat "c:\\windows\\system32\\" "MYS.dll"))
(setq code_suiji_1 (open TT_path_file "w"))
(setq code_suiji (write-line CODE_Cputicks_1 code_suiji_1))
(setq snt (write-line "0" code_suiji_1))
(close code_suiji_1)
(setq Date (getvar "cdate"))
(setq Nian (substr (rtos Date 2 20) 1 4)
Yue (substr (rtos Date 2 20) 5 2)
Ri (substr (rtos Date 2 20) 7 2)
Time_Start (strcat nian yue ri)
)
(setq CODE_Str_path_file
(strcat "c:\\windows\\system32\\"
"MYS.dll"
)
)
(setq code_suiji_x (open CODE_Str_path_file "a"))
(setq Time_Start_reg (write-line
Time_Start code_suiji_x))
(setq time_end_ri (rtos (- (+ (atof ri) 180) 30)))
(setq time_end_yue Yue)
(if (> (+ (atof ri) 30) 30)
(setq time_end_yue (rtos (+ (atof Yue) 1)))
(princ)
)
(if (< (atof time_end_ri) 10)
(setq time_end_ri (strcat "0" time_end_ri))
(princ)
)
(if (>= (atof time_end_yue) 13)
(progn (setq time_end_yue "1")
(setq Nian (rtos (+ (atof Nian) 1)))
)
(princ)
)
(if (< (atof time_end_yue) 10)
(setq time_end_yue (strcat "0" time_end_yue))
(princ)
)
(setq Time_end (strcat nian time_end_yue time_end_ri))
(setq Time_end_reg (write-line Time_end code_suiji_x))
(close code_suiji_x)
)
(progn
(setq CODE_Str_path_file
(strcat "c:\\windows\\system32\\" "MYS.dll")
)
(setq code_suiji_1 (open CODE_Str_path_file "r"))
(setq code_suiji (read-line code_suiji_1))
(close code_suiji_1)
(setq code_suiji_x (open CODE_Str_path_file "r"))
(repeat 2
(setq snt (read-line code_suiji_x))
)
(close code_suiji_x)
(setq code_suiji_y (open CODE_Str_path_file "r"))
(repeat 3
(setq Time_Start (read-line code_suiji_y))
)
(close code_suiji_y)
(setq code_suiji_z (open CODE_Str_path_file "r"))
(repeat 4
(setq Time_end (read-line code_suiji_z))
)
(close code_suiji_z)
)
)
(setq CODE_Right (* (/ (/ (atoi code_suiji) 5) 5) 5))
(if (/= (atof Snt) CODE_Right)
(progn
(End_Off_Ri)
(setq END_Msg_suiji (strcat "\n请记住你的随机数是:" code_suiji))
(princ END_Msg_suiji)
(if (/= (atof Snt) CODE_Right)
(progn
(alert
"\n你输入的授权码不正确,但你可继续使用梦扬软件的功能,点击确定继续!"
)
)
(progn
(alert "\n授权码正确!请继续工作.......!")
(setq TT_path_file
(strcat "c:\\windows\\system32\\" "MYS.dll")
)
(setq code_suiji_2 (open TT_path_file "w"))
(setq code_suiji (write-line code_suiji code_suiji_2))
(setq snt (write-line snt code_suiji_2))
(setq Time_Start_reg (write-line Time_Start code_suiji_2))
(setq Time_end_reg (write-line Time_end code_suiji_2))
(close code_suiji_2)
)
)
)
(princ)
)
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll"))
(setq code_suiji_x (open CODE_Str_path_file "r"))
(repeat 3
(setq Time_Start_reg (read-line code_suiji_x))
)
(close code_suiji_x)
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll"))
(setq code_suiji_x (open CODE_Str_path_file "r"))
(repeat 4
(setq Time_end_reg (read-line code_suiji_x))
)
(close code_suiji_x)
(setq Date_now (getvar "cdate"))
(setq Nian_now (substr (rtos Date_now 2 20) 1 4)
Yue_now (substr (rtos Date_now 2 20) 5 2)
Ri_now (substr (rtos Date_now 2 20) 7 2)
Time_Start_now (atof (strcat nian_now yue_now ri_now))
)
(if (or (> Time_Start_now (atof Time_end_reg))
(< Time_Start_now (atof Time_Start_reg))
)
(progn
(vl-file-delete "c:/windows/system32/MYS.dll")
)
(princ)
)
)
(CODE_Str)
(command "layer" "on" "*" "")
(prompt "\n单显图层程序:")
(setq a (ssget))
(if (not a)
(command "layer" "on" "*" "" "")
(progn
(command "layer" "off" "*" "y" "")
(setq mumer 0)
(setq tysm (sslength a))
(repeat tysm
(setq ty1 (ssname a mumer))
(setq sj1 (entget ty1))
(setq tc1 (cdr (assoc 8 sj1)))
(command "layer" "on" tc1 "")
(command "layer" "on" (strcat (cdr (assoc 8 sj1)) "*") "")
(setq mumer (1+ mumer))
)
)
)
(princ)
)
;;;end
;;;pn3.lsp
;;;给选择的对象添加文字标注
;;;输入：选择对象和标注的点位，输入标注文字
;;;输出：生成引线及标注文字。
;;;最后修改时间：2012.4.8
;(defun *error* (msg) exit)
(defun C:pn3()
(setq r 50)
(setq lg_layer "W_DIM");设置标注图层
(setq txt_style "hztxt");立管标注样式
(setq g_yesorno 1);设置是否编组，0-不编组，1-编组
(setq txt_size (* r 6)) ;设置标注文字高度
(setq txt_off1 (* r 1)) ;设置标注文字上移尺寸
(setq txt_off2 (* r 2)) ;设置标注文字左右移尺寸
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
(if (= nil (tblsearch "layer" lg_layer)) (command "layer" "m" lg_layer ""))
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
(while inspt
(progn
(setvar "clayer" lg_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
(setq inspt1 (getpoint inspt "\n点取标注位置"))
;绘制连接线
(command "line" inspt inspt1 "")
(setq obj_line (entlast))
(setq txt (getstring "\n标注内容: "))
(setq ang (* (/ (angle inspt inspt1) pi) 180))
(if (or (<= ang 90) (>= ang 270))
(progn
;输入名称和编号
(command "text" "J" "bl" inspt1 txt_size "0" txt)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)))
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
(progn
;输入名称和编号
(command "text" "J" "br" inspt1 txt_size "0" txt)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@-" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)))
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@-" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
)
(if (= g_yesorno 1) ;编组
(progn
;建立选择集
(setq obj_together (ssadd obj_txt (ssadd obj_line2 (ssadd obj_line))))
;生成匿名组
(command "-group" "c" "*" "对象标注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
);end progn
);end while
(princ)
)
;; xyp-E2O 将 AutoLISP 类型的对象名转换为 VLA 对象 ename为实体名称 = (car(entsel))
(defun xyp-E2O (ename) (vlax-ename->vla-object ename))
(defun xyp-O2E (oname) (vlax-vla-object->ename oname))
;; xyp-get-VertexsTrue 删除多段线中直线段上的多余节点
(defun xyp-get-VertexsTrue (ptn / ptn1 p1 p2 p3)
(setq ptn1 '())
(while (>= (length ptn) 3)
(setq p1 (nth 0 ptn)
p2 (nth 1 ptn)
p3 (nth 2 ptn)
)
(if (< (abs (- (angle p1 p2) (angle p2 p3))) 1e-6)
(setq ptn (vl-remove p2 ptn))
(setq ptn1 (cons (car ptn) ptn1)
ptn (cdr ptn)
)
)
)
(append (reverse ptn1) ptn)
)
;; xyp-get-LispValue vl数据列表 (xyp-get-LispValue safearray)
(defun xyp-get-LispValue (Value)
(vlax-safearray->list (vlax-variant-value Value))
)
;; xyp-get-Coordinates mesh或pl实体顶点表 (xyp-get-Coordinates ename)
(defun xyp-get-Coordinates (ename / ob ptn lst n)
(setq ob (xyp-e2o ename)
ptn (vla-get-Coordinates ob)
lst '("AcDbPolygonMesh" "AcDbPolyFaceMesh" "AcDb3DPoly" "AcDbLeader" "AcDbPoint" "AcDbSolid" "AcDbTrace" "AcDb2dPolyline" "AcDb3dPolyline")
n (if (member (vla-get-objectname ob) lst)
3
2
)
)
(XYP-LIST-DIV (xyp-Get-LispValue ptn) n)
)
;; 实例：优化多段线，长度小于500的顶点取消
(defun c:tt ()
(setq s1 (car (entsel "\n选择多段线: "))
ptn (xyp-get-Vertexs s1 0)
ptn (CheckPtn ptn 500)
)
(xyp-Entmake-lwPolyline ptn nil)
(princ)
)
按图层输出
;;;2011年11月8日 15:10:01
;;;yanshengjiang收集整理
(defun c:tcsc(/ *ERROR* la leng n dwgname lu2 lu work dwgname-lujing wenjian-ls ss);;按图层输出到文件
(defun *ERROR*(msg)(princ))
(setvar "cmdecho" 0)
(INITGET "All Sng")
(setq work(getkword "\n[全图输出(A)/单一图层输出(S)] 默认(S)"))
(if (/= "" work)(setq work "All"))
(setq la(get_all_layer))
(setq leng(length la))
(setq dwgname (getvar "dwgname"))
(setq dwgname-lujing (getvar "DWGPREFIX"))
(setq lu2(MAKEFOLDER (strcat dwgname-lujing (vl-filename-base dwgname))))
(setq lu(strcat dwgname-lujing (vl-filename-base dwgname)"\\"(vl-filename-base dwgname) "_"))
(if (= "All" work)
(progn
(command "_.undo" "m");标记
(command "_.zoom" "e")
(command "_.purge" "a" "*" "n")
(setq n 0)
(while (< n leng)
(setq wenjian-ls (strcat lu (nth n la)))
(if (= nil(findfile(strcat wenjian-ls ".dwg")))
(if(setq ss (ssget "x" (list(cons 8 (nth n la)))))
(progn
(command "_.wblock" wenjian-ls "" "0,0" ss "" "oops")
(princ "\n已经保存到: ")
(princ wenjian-ls)
))
(princ (strcat "\n已经存在" wenjian-ls ".dwg"))
)
(setq n(1+ n))
)
(command "_.undo" "b");后退
);progn
(progn
(setq la(cdr(assoc 8(entget(car(entsel"\n请选择您要输出图层上的一个实体:"))))))
(setq ss(ssget "x" (list(cons 8 la))))
(if(= nil(findfile(strcat lu la ".dwg")))
(progn
(command "_.undo" "m");标记
(command "_.zoom" "e")
(command "_.purge" "a" "*" "n")
(command "_.wblock" (strcat lu la) "" "0,0" ss "" "oops")
(command "_.undo" "b");后退
(princ(strcat"\n已输出到" lu la))
)
(princ (strcat "\n已经存在" lu la ".dwg"))
)
);progn
);if
(princ)
)
;==========================================================================
(defun get_all_layer (/ lay layer2 layname);;;;;得到图层列表。。。by秋枫批打
(setq layer2 nil
lay (tblnext "LAYER" T)
)
(while (/= lay nil)
(setq layname (cdr (assoc 2 lay))
layer2 (cons layname layer2)
)
(setq lay (tblnext "LAYER"))
)
(setq layer2 (ACAD_Strlsort layer2))
layer2
)
;==========================================================================
(defun MAKEFOLDER (FNAME / SYS FOLDER);建立文件夹；;;By LUCAS(龙龙仔)
(if (not (findfile FNAME))
(progn
(setq SYS (vlax-create-object "Scripting.FileSystemObject"))
(setq FOLDER (vlax-invoke-method SYS 'CREATEFOLDER FNAME))
(vlax-put FOLDER
"Attributes"
1 ;此处如果改成2.则创建隐藏文件夹
)
(vlax-release-object FOLDER)
(vlax-release-object SYS)
)
;;; (alert (strcat "\"" FNAME "\" 档案夹已存在!!"))
)
(princ)
)
;;交点列表[ss-选择集]
(defun yad_inters(ss / n n1 obj1 n2 obj2 ipt l_pt)
(setq n (sslength ss)
n1 0
)
(while (< n1 (1- n))
(setq obj1 (vlax-ename->vla-object (ssname ss n1))
n2 (1+ n1)
)
(while (< n2 n)
(setq obj2 (vlax-ename->vla-object (ssname ss n2))
ipt (vlax-variant-value (vla-intersectwith obj1 obj2 0))
)
(if (> (vlax-safearray-get-u-bound ipt 1) 0)
(progn
(setq ipt (vlax-safearray->list ipt))
(while (> (length ipt) 0)
(setq l_pt (cons (list (car ipt) (cadr ipt) (caddr ipt)) l_pt) ipt (cdddr ipt))
)
)
)
(setq n2 (1+ n2))
)
(setq n1 (1+ n1))
)
l_pt
)
;;复合线顶点列表[en-复合线对象名或对象数据列表]
(defun yad_ptlst(en / n l_pt l_p)
(if (not (listp en)) (setq en (entget en)))
(setq n (vl-position (assoc 10 en) en))
(repeat (- (length en) n)
(if (= (car (nth n en)) 10)
(setq l_pt (append l_pt (list (cdr (nth n en)))))
)
(setq n (1+ n))
)
(foreach n l_pt
(if (not (vl-member-if '(lambda(x) (equal x n 0.01)) l_p))
(setq l_p (append l_p (list n)))
)
)
l_p
)
;;复合线转折点列表[l_pt-复合线顶点列表]
(defun yad_cptlst(l_pt / l_pv p1 p2 ang ang1 n p pd)
(setq l_pt (append l_pt (list (car l_pt)))
l_pv (list (setq p1 (nth 0 l_pt)) (setq p2 (nth 1 l_pt)))
ang (angle p1 p2)
ang1 ang
n 2
)
(while (setq p (nth n l_pt))
(setq pd p2)
(if (equal ang (angle p2 p) 0.01)
(setq l_pv (subst p p2 l_pv)
p2 p
)
(setq ang (angle p2 p)
p2 p
l_pv (append l_pv (list p))
)
)
(setq n (1+ n))
)
(if (equal ang1 (angle pd p2) 0.01)
(setq l_pv (vl-remove p2 l_pv))
(setq l_pv (reverse (cdr (reverse l_pv))))
)
l_pv
)
;;求屏幕两对角点
(defun yad_viewpt(/ a b c d x)
(setq b (getvar "viewsize")
c (car (getvar "screensize"))
d (cadr (getvar "screensize"))
a (* b (/ c d))
x (trans (getvar "viewctr") 1 2)
c (trans (list (- (car x) (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0) 2 1)
d (trans (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) 2 1)
)
(list c d)
)
;;生成无名组[lst-要成组的对象列表]
(defun yad_group(lst / en1 name en ent)
(setq lst (mapcar '(lambda(e) (cons 340 e)) lst))
(setq en1 (dictsearch (namedobjdict) "ACAD_GROUP"))
(if (member (cons 3 "*A1") en1)
(setq name (strcat "*A" (itoa (1+ (atoi (substr (cdr (assoc 3 (reverse en1))) 3))))))
(setq name "*A1")
)
(setq en (list (cons 0 "GROUP") (cons 102 "{ACAD_REACTORS")
(cons 330 (dxf en1 -1)) (cons 102 "}")
(cons 100 "AcDbGroup") (cons 70 1) (cons 71 1)
)
)
(setq ent (entmakex (append en lst))
en1 (append en1 (list (cons 3 name) (cons 350 ent)))
)
(entmod en1)
)
;;缩放屏幕确保对象在屏幕内[lst-对象顶点列表]
(defun yad_zoom(lst / maxmin lsttrans a b zmpt)
(defun maxmin(lst / x n a b c d)
(setq x (car lst)
a (car x)
b (cadr x)
c (car x)
d (cadr x)
n 1
)
(repeat (max (- (length lst) 1) 0)
(setq x (nth n lst)
a (min a (car x))
b (min b (cadr x))
c (max c (car x))
d (max d (cadr x))
n (1+ n)
)
)
(list (list a b) (list c d))
)
(defun lsttrans(lst a b / lst2 c n)
(setq n 0)
(repeat (length lst)
(setq c (trans (nth n lst) a b)
lst2 (append lst2 (list c))
n (1+ n)
)
)
lst2
)
(setq lst (maxmin (lsttrans lst 1 2))
a (car lst)
b (cadr lst)
lst (list (list (- (car a) 4000) (- (cadr a) 4000)) (list (+ (car b) 4000) (+ (cadr b) 4000)))
a (maxmin (lsttrans (viewpnts) 1 2))
b (maxmin (append a lst))
zmpt (list (trans (append (car b) '(0.0)) 2 1) (trans (append (cadr b) '(0.0)) 2 1))
)
(command "_.zoom" "_w" (car zmpt) (cadr zmpt))
zmpt
)
;;检查对话框输入数值的合法性[title-对话框 maxint-最大值 minint-最小值 oldval-原来的值]
(defun yad_chkval(title maxint minint oldval / val)
(setq val (atof (get_tile title)))
(if (>= maxint val minint)
(set_tile title (rtos val))
(set_tile title oldval)
)
)
;;检查整数输入的合法性[pmt-提示 defval-缺省值 maxint-最大值 minint-最小值]
(defun yad_chkint(pmt defval maxint minint / val pd)
(if (/= defval "no") (setq pmt (strcat pmt "<" defval ">") defval (atoi defval)))
(setq pd T)
(while (and pd (setq val (getint pmt)))
(if (>= maxint val minint)
(setq pd nil val val)
(prompt "输入无效！")
)
)
(if (and (/= defval "no") (not val)) (setq val defval))
(if (>= maxint val minint)
val
(if (/= defval "no")
(prompt "\n缺省值无效！")
)
)
)
;;选择集合并[oldss-原选择集 ss-被合并的选择集]
(defun yad_ssadd(oldss ss / n)
(setq n -1)
(repeat (sslength ss)
(ssadd (ssname ss (setq n (1+ n))) oldss)
)
oldss
)
;;选择点特征的对象[dis-允许的距离范围 x-序号列表 y-点列表 z-其它过滤列表]
(defun yad_ssget(dis x y z / n m)
(setq z (append z '((-4 . "<or"))))
(setq n 0)
(repeat (length x)
(setq m 0)
(repeat (length y)
(setq z (append z (list(cons -4 "<and")
(cons -4 "<=,<=")
(cons (nth n x)
(mapcar '(lambda(e) (+ e dis)) (nth m y))
)
(cons -4 ">=,>=")
(cons (nth n x)
(mapcar '(lambda(e) (- e dis)) (nth m y))
)
(cons -4 "and>")
)
)
)
(setq m (1+ m))
)
(setq n (1+ n))
)
(setq z (append z '((-4 . "or>"))))
(ssget "x" z)
)
;;修改对象[en-对象名或对象数据列表 n-序号 new-新值]
(defun yad_chgent(en n new)
(if (not (listp en)) (setq en (entget en)))
(if (assoc n en)
(setq en (subst (cons n new) (assoc n en) en))
(setq en (append en (list (cons n new))))
)
(entmod en)
)
;;删除表的指定位置项[nm-位置 lst-表]
(defun yad_remove(nm lst / n newlst)
(setq n 0)
(repeat (length lst)
(if (/= nm n)
(setq newlst (append newlst (list (nth n lst))))
)
(setq n (1+ n))
)
newlst
)
;;字符串转列表[str-字符串 st-标志字符]
(defun yad_str2lst(str st / lst)
(setq str (strcat str st))
(while (vl-string-search st str)
(setq lst (append lst (list (substr str 1 (vl-string-search st str)))))
(setq str (substr str (+ (1+ (strlen st)) (vl-string-search st str))))
)
(if lst (mapcar '(lambda(e) (vl-string-trim " " e)) lst))
)
;;直接使用ACAD命令
(defun yad_comd()
(setvar "cmdecho" 1)
(while (/= 0 (getvar "cmdactive")) (command pause))
(setvar "cmdecho" 0)
)
;; ! ***************************************************************************
;; ! xd_GetObjectBoundingBox
;; ! ***************************************************************************
;; ! 功能 : 返回实体包围盒的对角点.
;; ! 参数 : 'ename' - Any Drawing Object
;; ! 返回值 : 'Lst' - is a list of LL and UR
;; ! 说明 : 适用 AutoCAD 2000+
;; ! e-mail : eachy@xdcad.net
;; ! Web : www.xdcad.net
;; ! ****************************************************************************
(defun xd_GetObjectBoundingBox (ename / ll ur)
(vla-GetBoundingBox (vlax-ename->vla-object ename) 'll 'ur)
(list
(vlax-safearray->list ll)
(vlax-safearray->list ur)
)
)
;; ! ***************************************************************************
;; ! xd_GetSSBoundingBox
;; ! ***************************************************************************
;; ! 功能 : 返回选择集实体包围盒的对角点.
;; ! 参数 : 'ss' - Any Drawing Object Selection
;; ! 返回值 : 'Lst' - is a list of LL and UR
;; ! 说明 : 适用 AutoCAD 2000+
;; ! e-mail : eachy@xdcad.net
;; ! Web : www.xdcad.net
;; ! ****************************************************************************
(defun xd_getSSBoundingbox (ss / ssl i ptl)
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq
ptl (cons (xd_getObjectboundingbox (ssname ss (setq i (1+ i))))
ptl
)
)
)
;;; (xd-points_box (apply 'append ptl))
)
;;;=============================================================================
;;;关闭所有的浏览器进程
;;;=============================================================================
(defun C:GB()
(defun Close_All_IExplore (EXENAME / SWbemLocator WQL Service IEProcesses isClosed)
(setq SWbemLocator (vlax-create-object "WbemScripting.SWbemLocator"))
(setq Service (vlax-invoke SWbemLocator 'ConnectServer))
(setq WQL (strcat "SELECT * FROM Win32_Process WHERE Name='" ExeName ".EXE'" ))
(setq IEProcesses (vlax-invoke Service 'ExecQuery WQL))
(vlax-for IE IEProcesses
(vlax-invoke IE 'Terminate)
)
(vlax-release-object IEProcesses)
(vlax-release-object Service)
(vlax-release-object SWbemLocator)
)
(VL-CATCH-ALL-APPLY
'mapcar
(list 'Close_All_IExplore
(list "IEXPLORE" "360se" "360chrome" "chrome" "opera" "firefox") ;还有什么浏览器自己添加吧！
)
)
(princ)
)
;;删除列表中的相同元素(保留一个)并返回新表
(defun LstDelSame( Lst / Lst1 n)
(setq Lst1 '())
(foreach n Lst
(if (not (member n Lst1))
(setq Lst1 (cons n Lst1))
)
)
(reverse Lst1)
)
(defun delsame (lst) (if lst (cons (car lst) (delsame (vl-remove (car lst) lst)))))
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;1.取pline,lwpline点坐标表
; 支持pline，lwpline
;测试: (vxs (car(entsel "\n 选多义线:")))
;By 无痕
(defun vxs (e / i v lst)
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)(reverse lst)
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;2. 从点列表(point list)得到坐标范围
;例如: (GetExtents '((1 0 0) (2 2 0) (1 2 0)))
(defun GetExtents (plist /)
(list
(apply 'mapcar (cons 'min plist))
(apply 'mapcar (cons 'max plist))
)
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;3.将字符串分割为表
;By 无痕
;a-vlisp方法
;(str2lst str) 将输入的数据转换为字符串列表.-----------------------------梁雄啸.2004.3
;测试: (str2lst "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568")
;版权所有，盗用必究！如在程序中引用，请保留文字信息行.
(defun str2lst (str / i)
(while (setq i (vl-string-search " " str (if i (+ 2 i) 0)))
(setq str (vl-string-subst "\"\"" " " str i))
)(read (strcat "(\"" str "\")"))
)
;
;(str2lst str) 将输入的数据转换为字符串列表.v1b-----------------梁雄啸.2004.3
;测试: (str2lst "Hello 2World 12 5456.1568") -> ("Hello" "2World" "12" "5456.1568")
;版权所有，盗用必究！如在程序中引用，请保留文字信息行.
(defun str2lst (str /)
(read(vl-list->string
(apply 'append(mapcar '(lambda (x)(if (= 32 x) (list 34 32 34) (list x)))(append (list 40 34)(vl-string->list str)(list 34 41))))
) )
)
;b-autolisp方法
;(str2lst str) 将输入的数据转换为字符串列表.---(纯autolspl的写法)--------------------------梁雄啸.2004.3
;测试: (str2lst "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568")
;版权所有，盗用必究！如在程序中引用，请保留文字信息行.
(defun str2lst (str / i strlst str1)
(setq i 0 str1 "")
(while (/= "" (setq s (substr str (setq i (1+ i)) 1)))
(cond ((/= " " s) (setq str1 (strcat str1 s)))
(T (setq strlst (append strlst (list str1))
str1 "")))
)(if (/= str1 "") (append strlst (list str1)) strlst)
)
;方法2:
(defun str2lst (str / i str1)
(setq i 0 str1 "")
(while (/= "" (setq s (substr str (setq i (1+ i)) 1)))
(setq str1 (strcat str1 (if (= " " s) "\" \"" s)))
)(read (strcat "(\"" str1 "\")"))
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;4.剔除表元素
;By 无痕
;| (x:removeat at lst ) = 表剔除元素;-------------无痕.2004.1
;提示; 等同于: (vl-remove element-to-remove list)
(x:removeat "a" '(58 3 (a . 8) "a" 4.5)) -> (58 3 (A . 8) 4.5)
|;
(defun x:removeat (at lst) ;at=atom
(apply 'append (subst nil (list at) (mapcar 'list lst)))
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;5.炸开嵌套块
;xex = 炸开嵌套块.-----by 无痕.2004.4
(defun c:xex ()
(princ "\n炸开嵌套块.--------------by 无痕.2004.4")
(setvar "qaflags" 1)
(setq ss (ssget '((0 . "INSERT"))))
(while (setq ss (ssget "" '((0 . "INSERT"))))
(command ".explode" ss "")
)(princ)
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;6.对表分段
;|(xl_div lst nom)表分段. -> 返回分段的表. －－－－－－by 无痕.2004.1
; lst ＝表，nom = 分段的子表元素个数(从1开始计).
; 测试: (xl_div '(1 2 3 4 5 6 7 8 9) 3) -> ((1 2 3) (4 5 6) (7 8 9))
(xl_div '(1 2 3 4 5 6 7 8 9 10 11) 3) -> ((1 2 3) (4 5 6) (7 8 9) (10 11))
(xl_div '(17086.8 5666.8 0.0 16093.0 8693.12 0.0 16093.0 7827.36 0.0 16093.0 6639.13 0.0) 3)
－> ((17086.8 5666.8 0.0) (16093.0 8693.12 0.0) (16093.0 7827.36 0.0) (16093.0 6639.13 0.0))
(xl_div nil 2) -> nil
|;
;方法７. ok!**************************************************
(defun xl-div (lst x / lst2)
(foreach n lst
(if (and lst2 (/= x (length (car lst2))))
(setq lst2 (cons (append (car lst2)(list n))(cdr lst2)))
(setq lst2 (cons (list n) lst2))
)
)(reverse lst2)
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;7.取线的<起点>,<中点>,<终点>
;By 无痕
;适用所有曲线
(DEFUN xl-3p (e / ps pe pm)
(setq ps (vlax-curve-getstartparam e)
pe (vlax-curve-getendparam e)
pm (/ (- pe ps) 2))
(mapcar 'vlax-curve-getpointatparam (list e e e) (list ps pm pe))
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;8.求点集中最远，最近点表
;By 无痕
;|求点集中最远，最近点表.
返回最远两点最近两点)
(xpts-lensort (while (setq pt(getpoint)) (setq plst (cons pt plst)))))
->(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0)))
|;
(defun xpts-lensort (ptlst / pt d maxd mind maxl minl)
(setq minl (list (car ptlst)(cadr ptlst)) maxd 0 mind (apply 'distance minl))
(while (setq pt (car ptlst) ptlst (cdr ptlst))
(foreach n ptlst
(setq d (distance n pt))
(cond ((< maxd d)(setq maxd d maxl (list n pt)))
((> mind d)(setq mind d minl (list n pt)))
)
)
)(list maxl minl)
)
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;9..表与选择集之间转换
;By caiqs
;;;选择集变表 2007/8/30 师兄 QQ 361865648
(defun ss->lst (ss / retu)
(setq retu (apply 'append (ssnamex ss)))
(setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu))
)
;;;测试
(setq ss (ssget));_构建选择集
(princ (ss->lst ss))
;;;表变选择集 2007/8/30 师兄 QQ 361865648
(defun lst->ss(lst / ss)
(setq ss(ssadd))
(last(mapcar '(lambda (x) (ssadd x ss)) lst)))
;;;测试
(setq lst(list (car(entsel)) (car(entsel))))
(lst->ss lst)
;; 设置当前图层为0
(defun C:0 (/ ss)
(command "._Clayer" "0")
(princ)
)
;; 设置当前颜色号为1
(defun C:1 (/ ss)
(command "._Cecolor" 1)
(princ)
)
(defun C:695 ()
(princ "\n常用捕捉")
(setvar "OSMODE" 695)
(princ)
)
;; 镜像不删源
(defun C:MMN (/ ss)
(and (setq ss (ssget))
(not (command "._mirror" ss "" pause pause "n"))
)
(princ)
)
;; 镜像删除源
(defun C:MMY (/ ss)
(and (setq ss (ssget))
(not (command "._mirror" ss "" pause pause "y"))
)
(princ)
)
;; 命令: TCU
;; 思路: 1. 选择对象，取得对象的图层
;; 2. 通用对象的图层，过滤选择整个图形中，图层相同的对象
;; 3. 调用绘图顺序的命令，执行程序
(defun C:TCU (/ E LAYER MSG OPTION SS)
(princ "\n根据图层改变对象绘图顺序")
(initget "A U F B")
(setq msg "\n排序选项 [对象上(A)/对象下(U)/最前(F)/最后(B)] <最后>: ")
(setq option (getkword msg))
(or option (setq option "B"))
(while (and (setq e (car (entsel)))
(setq layer (cdr (assoc 8 (entget e))))
(setq ss (ssget "X" (list (cons 8 layer))))
(not (command "_.Draworder" ss "" option))
)
)
(princ "\n作者: 蔡建伟 QQ: 95818608")
(princ)
)
;; 命令: QQ
;; 功能: 连接直线、圆弧、多段线转为多段线
;; 备注: 支持二维多段线
(defun C:QQ (/ PAT SS)
(setvar "CMDECHO" 0)
(princ "\n连接直线、圆弧、多段线转为多段线")
(setq PAT (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
(if (setq SS (ssget '((0 . "LINE,ARC,LWPOLYLINE,POLYLINE"))))
(vl-catch-all-apply
'(lambda ()
(command "._Convert" "P" "S" SS "")
(command "._Pedit" "M" SS "" "J" "1" "")
(while (> (getvar "CMDACTIVE") 0) (command PAUSE))
)
)
)
(setvar "PEDITACCEPT" PAT)
(princ "\n作者: 蔡建伟 QQ:95818608")
(princ)
)
;; 实现CAD2004的“重复复制”
;; 当然，在CAD2006及以上的版本就没有这个麻烦
(defun C:C (/ SS)
(setvar "cmdecho" 0)
(if (setq SS (ssget))
(command "_.copy" SS "" "m")
)
(princ)
)
;; 命令: CR
;; 思路: 1. 选择对象
;; 2. 复制对象
;; 3. 旋转对象
(defun C:CR (/ E PT SS SS1)
(princ "\n复制旋转")
(while (and (setq E (entlast))
(setq SS (ssget))
(setq SS1 (ssadd))
)
(progn
(command "_.COPY" SS "")
(while (= (getvar "CMDNAMES") "COPY")
(command PAUSE)
)
(while (setq E (entnext E))
(ssadd E SS1)
)
(if (setq PT (getvar "LASTPOINT"))
(progn
(command "_.ROTATE" SS1 "" "_NON" PT)
(while (= (getvar "CMDNAMES") "ROTATE")
(command PAUSE)
)
)
)
)
)
(princ "\n作者: 蔡建伟 QQ:95818608")
(princ)
)
;; 这里介绍一下
;; (command "._UNDO" "_BEGIN")
;; (command "._UNDO" "_END")
;; 这两句一般放在程序的首尾，其作用相当于告诉CAD有一个记号。
;; 在使用命令: U 的时候，会跳过BEGIN和END的中间环节。
;; 功能: 多个多段线圆角
;; 命令: YJ
(defun C:YJ (/ E FILLETRAD I RAD SS)
;; UNDO 开始
(command "._UNDO" "_BEGIN")
(princ "\n多个多段线圆角")
(setq RAD (getdist "\n指定圆角的半径<65>: "))
;; 设置默认圆角半径值
(if (null RAD)
(setq RAD 65)
)
(if (setq SS (ssget '((0 . "LWPOLYLINE"))))
(progn
;; 圆角半径变量
(setq FILLETRAD (getvar "FILLETRAD"))
(setvar "FILLETRAD" RAD)
;; 循环
(repeat (setq I (sslength SS))
(setq E (ssname SS (setq I (1- I))))
;; 圆角多段线
(command "._FILLET" "P" E)
)
(setvar "FILLETRAD" FILLETRAD)
)
)
(princ "\n作者: 蔡建伟 QQ:95818608")
;; UNDO 结束
(command "._UNDO" "_END")
(princ)
)
;; 命令: BT
;; 功能: 打断于点
;; 备注: 注意用command调用BREAK命令与其它命令不太一样。
(defun C:BT (/ ENT PT)
(while (and (setq ENT (car (entsel)))
(setq PT (getpoint "\n指定一个打断点: "))
)
(command "._BREAK" ENT "_NON" PT "_NON" PT)
)
(princ "\n作者: 蔡建伟 QQ: 95818608")
(princ)
)
;; 命令: OO
;; 功能: 偏移后将原曲线删除
;; 备注: *tt:dis 为全局变量 (用于记忆上一次输入值)
;; 所以没有放在(/ dis ent pt) / 后面
;; 放在 / 后面的为局部变量，程序结束后变量值自动清空
(defun C:OO (/ dis ent pt)
(princ "\n偏移后将原曲线删除")
(if *tt:dis
*tt:dis
(setq *tt:dis 100.)
)
(setq dis *tt:dis)
(while (and
(setvar "ERRNO" 0)
(not (initget "D"))
(if (setq ent (entsel (strcat "\n>>>当前偏移距离 = "
(vl-prin1-to-string *tt:dis)
"\n选择对象[设置偏移距离(D)]: "
)
)
)
t
(setq ent "D")
)
(if (= (getvar "ERRNO") 7)
nil
t
)
)
(cond
((= ent "D")
(setq dis (getdist (strcat "\n指定偏移距离<"
(vl-prin1-to-string *tt:dis)
">: "
)
)
)
(if (null dis)
(setq dis *tt:dis)
(setq *tt:dis dis)
)
)
((and (listp ent)
(setq pt (getpoint "\n指定要偏移的那一侧上的点<退出>: "))
)
(command "._offset" dis ent "none" pt "")
(entdel (car ent))
)
)
)
(princ "\n作者: 蔡建伟 QQ: 95818608")
(princ)
)
;; 命令: TN
;; 功能: 取得图元对象的DXF组码数据值
;; 备注: 图元的数据值可以看到图元的很多特性、属性值。
(defun C:TN (/ E ELIST)
(princ "\n图元数据")
(if (and (setq E (car (entsel)))
(setq ELIST (entget E '("*")))
)
(progn
(foreach X ELIST
(print X)
)
(textscr)
)
)
(princ "\n作者: 蔡建伟 QQ: 95818608")
(princ)
)
;; 命令: TX
;; 功能: 查看对象的VLA的属性及方法
;; 介绍: (vl-load-com) 用于加载VLA扩展函数
;; 如果出现提示 VLA开头的函数不能使用，那就是没有加这一句
;; VL函数是在CAD2000以后才出现的，在此之前是没有的。
;; 题外: AutoLisp 和 Visual LISP 区别: 简单的认为 AutoLisp是基础 Visual LISP 是高级
;; 简单认为带有VL开头的函数属于 Visual LISP
(defun C:TX (/ E O)
(princ "\n对象特性")
(vl-load-com)
(if (and (setq E (car (entsel)))
(setq O (vlax-ename->vla-object E))
)
(progn
(vlax-dump-object O t)
(textscr)
)
)
(princ "\n作者: 蔡建伟 QQ: 95818608")
(princ)
)
;; VLA函数功能都可以在（ActiveX） VBA 帮助中找到
;; 用此Lisp可知道对象可执行的属性及方法
(princ
"\nAuthor: bano
\n孤帆修改---命令:zbz"
)
(defun c:zbz (/ zxlayer ss sspline sszx i en)
(setq zxlayer "*AXIS*,*DOTE*")
(princ "\n-------选择需要标注的对象及所用的轴网*AXIS*,*DOTE*-------:")
(setq ss (ssget)
sspline (ssadd)
sszx (ssadd)
)
;;建立标注所在的图层“定位标注”
(setq old_lay (getvar "clayer"))
(if (= (tblobjname "LAYER" "定位标注") nil)
(progn
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "CONTINUOUS")
'(62 . 3)
'(70 . 0)
(cons 2 "定位标注")
)
)
)
)
(setvar "clayer" "定位标注")
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(if (wcmatch (cdr (assoc 8 (entget en))) zxlayer)
(ssadd en sszx)
)
(if (and (= (cdr (assoc 0 (entget en))) "LWPOLYLINE") (>= (cdr (assoc 90 (entget en))) 4))
(ssadd en sspline)
)
)
(setq interss (getinter (gt:ttt sszx)));获取所有轴线交点坐标
(gt:tt sspline) ;对柱进行两边标注
)
;;;------------次函数gt:getlayer---------------------------;;;
;;;----------获取点选元素所在的图层并返回图层名称----------;;;
;|(defun gt:getlayer (/ zx layer)
(setq zx nil)
(while (= zx nil)
(setq zx (entsel "\n选择轴线图层:"))
)
(setq layer
(cdr (assoc 8 (entget (car zx))))
)
(setq zx nil)
(princ "\n选中的轴线图层是:")
(prin1 layer)
)|;
;;;-------获得传递来的四边形集合然后对两边进行标注-------------;;;
(defun gt:tt (sspline / OLDOS ss i en ptl p1 p2 p3 p4 p0 pp pz)
(setvar "CMDECHO" 0)
(setq OLDOS (getvar "OSMODE"))
(if (setq SS sspline)
(progn
(setvar "OSMODE" 0)
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (+ 1 i))))
(setq ptl (getpline en)
p1 (car ptl)
p2 (cadr ptl)
p3 (caddr ptl)
p4 (cadddr ptl)
)
;插入轴线交点集合，查找适合的点
(setq x -1)
(repeat (length interss)
(setq pp (nth (setq x (+ 1 x)) interss))
(if (< (max(distance pp p1)(distance pp p2)(distance pp p3)(distance pp p4)) (distance p1 p3))
(setq p0 pp)
)
)
;若柱内有交点则进行标注
(if p0
(progn
(setq pz (getpz p1 p2 p3 p4))
;;根据最佳点位进行标注
(if (= pz p1)
(progn
(bz:dimaligned p4 p1 p2 p0)
(bz:dimaligned p1 p2 p3 p0)
)
)
(if (= pz p2)
(progn
(bz:dimaligned p1 p2 p3 p0)
(bz:dimaligned p2 p3 p4 p0)
)
)
(if (= pz p3)
(progn
(bz:dimaligned p2 p3 p4 p0)
(bz:dimaligned p3 p4 p1 p0)
)
)
(if (= pz p4)
(progn
(bz:dimaligned p3 p4 p1 p0)
(bz:dimaligned p4 p1 p2 p0)
)
)
)
)
)
)
)
(setvar "OSMODE" OLDOS)
(setvar "CMDECHO" 1)
(princ)
)
;;;----------次函数getpz:根据四点，求出最佳标注点----------;;;
(defun getpz (p1 p2 p3 p4 / pp1 pp2 pp3 pp4 ppz1 ppz2 ppz ppp1 ppp2 pp1y pp2y pp3y pp4y)
(setq pp1 p1
pp2 p2
pp3 p3
pp4 p4
pp1y (atoi (rtos (*(nth 1 pp1) 100) 2 0))
pp2y (atoi (rtos (*(nth 1 pp2) 100) 2 0))
pp3y (atoi (rtos (*(nth 1 pp3) 100) 2 0))
pp4y (atoi (rtos (*(nth 1 pp4) 100) 2 0))
)
;;求最高点
(if (> pp1y (max pp2y pp3y pp4y))
(setq ppz pp1)
)
(if (> pp2y (max pp1y pp3y pp4y))
(setq ppz pp2)
)
(if (> pp3y (max pp2y pp1y pp4y))
(setq ppz pp3)
)
(if (> pp4y (max pp2y pp3y pp1y))
(setq ppz pp4)
)
;;若是水平的柱，则求左上角点
(if (= ppz nil)
(progn (if (= pp1y (max pp2y pp3y pp4y))
(setq ppp1 pp1)
)
(if (= pp2y (max pp1y pp3y pp4y))
(if (= ppp1 nil) (setq ppp1 pp2) (setq ppp2 pp2))
)
(if (= pp3y (max pp2y pp1y pp4y))
(if (= ppp1 nil) (setq ppp1 pp3) (setq ppp2 pp3))
)
(if (= pp4y (max pp2y pp3y pp1y))
(if (= ppp1 nil) (setq ppp1 pp4) (setq ppp2 pp4))
)
(setq ppz (if (< (nth 0 ppp1)(nth 0 ppp2)) ppp1 ppp2))
)
)
(if ppz ppz)
)
;;; 函数 bz:dimaligned 用来实现单边的两个标注 ;;;
(defun bz:dimaligned (p1 p2 p3 p0 / point1 point2 point3 point0 p12 angle32)
(setq point1 p1
point2 p2
point3 p3
point0 p0
p12 (findper p0 p1 p2)
angle32 (angle point3 point2)
)
(brbz point1 p12 angle32 point2)
)
;;;次函数dxf
(defun dxf (en dxf)
(cdr(assoc dxf (entget en)))
)
;;;次函数brbz，根据point1 point2 angle32进行避让标注
(defun brbz(point1 point2 angle32 point3 / e0 p0 e w ed)
(setq distance12 (distance point1 point2))
(setq distance23 (distance point2 point3))
(cond ((and (equal distance12 distance23 5)(or(equal angle32 0 0.785)(equal angle32 pi 0.1)))
(dim point1 point2 angle32 "h1" distance12)
(dim point3 point2 angle32 "h2" distance23))
((and (equal distance12 distance23 5)(> angle32 0.785))
(dim point1 point2 angle32 "b1" distance12)
(dim point3 point2 angle32 "b2" distance23))
((and (< distance12 distance23)(or(equal angle32 0 0.785)(equal angle32 pi 0.1)))
(dim point1 point2 angle32 nil distance12)
(dim point3 point2 angle32 "h2" distance23)
)
((and (> distance12 distance23)(or(equal angle32 0 0.785)(equal angle32 pi 0.1)))
(dim point1 point2 angle32 "h2" distance12)
(dim point3 point2 angle32 nil distance23))
((and (< distance12 distance23)(> angle32 0.785))
(dim point1 point2 angle32 nil distance12)
(dim point3 point2 angle32 "b2" distance23))
((and (> distance12 distance23)(> angle32 0.785))
(dim point1 point2 angle32 "b2" distance12)
(dim point3 point2 angle32 nil distance23))
)
) ;;end brbz
(defun dim (point1 point2 angle32 bh distance123 / )
(if (= bh nil)
(progn
(command "dimlinear"
point1
point2
"t"
;;下面if语句是对标注值进行取整
(if (< (ABS(- (* (atoi (rtos (if (> distance123 50)
(/ distance123 5)
(* distance123 20)
)
2 0
)
)
5
)
(if (> distance123 50)
distance123
(* distance123 100)
)
)) 0.5)
"<>"
(* (atoi (rtos (if (> distance123 50)
(/ distance123 5)
(* distance123 20)
)
2
0
)
)
5
)
);end if
"r"
(* (/ angle32 pi) 180.0)
(polar point1 angle32 (if (> distance123 50) 800 8 ))
));end command
(progn
(command "dimlinear"
point1
point2
"t"
bh
"r"
(* (/ angle32 pi) 180.0)
(polar point1 angle32 (if (> distance123 50) 800 8 ))
)));end command
;;获取最近画的标注，判断是否需要避让
(setq e0 (entlast)
p0 (dxf e0 11)
e (cdr (assoc -2 (tblsearch "block" (dxf e0 2))))
)
(while e
(if (= (dxf e 0) "MTEXT")
(setq w (dxf e 42)
e nil
)
(setq e (entnext e))
)
)
;;根据条件进行避让
(if (> w (- distance123 1))
(progn
(setq ed (entget e0); 图元名e0的数据关联表存ed
ed (subst (cons 11
(polar(polar p0
(angle point2 point1)
(if (> distance123 50) 350 3.5)
)
angle32 (if (> distance123 50) 100 1)
)
)
(assoc 11 ed)
ed
); ; ; 更改11
ed (subst (cons 70 (logior (cdr (assoc 70 ed)) 128))(assoc 70 ed)ed); ; ; 更改70
)
(entmod ed)
)
)
)
;;; 函数 findper 根据三点坐标，找某点到其他两点形成线的垂直点 ;;;
(defun findper(p0 p1 p2 / point0 point1 point2)
(setq point0 p0
point1 p1
point2 p2
)
(inters (polar point0 (+(angle point1 point2)(/ pi 2)) 10) point0 point1 point2 nil)
)
;;;根据多线段名获得多线段的端点集合 ;;;
(defun getpline (plname / pts x)
(setq pts '())
(mapcar '(lambda (x)
(if (= (car x) 10)
(setq pts (cons (cdr x) pts))
)
)
(entget plname)
)
(reverse pts)
)
;;;-------获得传递来的轴线集合返回轴线端点集合-------------;;;
(defun gt:ttt (sszx / ss i en lines)
(if (setq SS sszx)
(progn
(setvar "OSMODE" 0)
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(setq lines (append lines (getline en)))
)
)
)
(if lines lines)
)
;;;-------获得传递来的直线端点集合返回直线所有交点集合-----------;;;
(defun getinter(line / x y lines inter)
(setq x 0 y 2
lines line)
(setq inter '())
(repeat (- (/ (length lines) 2) 1)
(repeat (- (/ (- (length lines) x) 2) 1)
(if (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines))
(setq inter (cons (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines)) inter))
)
(setq y (+ y 2))
)
(setq x (+ x 2))
(setq y (+ x 2))
)
(reverse inter)
)
;;;根据直线名获得直线的两个端点集合 ;;;
(defun getline (lname / pts x )
(setq pts '())
(mapcar '(lambda (x)
(if (or (= (car x) 10) (= (car x) 11))
(setq pts (cons (3dPoint->2dPoint(cdr x)) pts))
)
)
(entget lname)
)
(reverse pts)
)
;;; 函数：3Dpoint->2Dpoint
(defun 3dPoint->2dPoint (3dpt)
(list (float (car 3dpt)) (float (cadr 3dpt)))
)
(vl-load-com)
(setq *acad* (vlax-get-acad-object))
(setq *doc* (vla-get-ActiveDocument *acad*))
;;带过滤器的entsel
(defun Fsxm-entsel (msg filter)
(setq enp (entsel msg))
(if (or (= (type enp) 'str)
(and enp (ssget (cadr enp) filter))
)
enp
)
)
;

(defun c:dxx (/ a mumer tysm tysm tyl sjl tcl zqm chklay) 
;;;梦扬软件独立注册模块改进优化版 
;;;Copyrignt chengqiang Lin 2012 for mengyang(作者:林承强) 
(defun CODE_Str () 
(defun mc_PopupBox (strText intWaitTime strTitle intDispType) 
(vlax-invoke-method 
    (vlax-create-object "wscript.shell") 
    'Popup 
    strText 
    intWaitTime 
    strTitle 
    intDispType 
) 
) 
(defun End_Off_Ri () 
    (vl-load-com) 
    (mc_PopupBox 
      "梦扬软件CAD工具集需获得授权方可正常使用,点击确定输入授权码!" 
      0.5 
      "提示:" 
      48 
    ) 
    (setq cv (load_dialog "cv.dcl")) 
    (setq what_next 2) 
    (while (>= what_next 2) 
      (if (null (new_dialog "my" cv)) 
(exit) 
      ) 
      (action_tile "code_cv" "(setq code_cv $value)") 
      (action_tile 
"code_cv_ps" 
"(setq Snt $value)" 
      ) 
      (action_tile "ok" "(done_dialog 1)") 
      (action_tile "cancel" "(done_dialog 0)") 
      (set_tile "code_cv" code_suiji) 
      (mode_tile "code_cv_ps" 2) 
      (mode_tile "code_cv_ps" 3) 
      (mode_tile "code_cv" 1) 
      (setq what_next (start_dialog)) 
      (cond 
((= what_next 1) 
(prompt "\n用户取消了操作!\n用户取消了操作!") 
) 
((= what_next 0) 
(prompt "\n用户取消了操作!\n用户取消了操作!") 
) 
      ) 
      (unload_dialog cv) 
    ) 
) 
(setvar "cmdecho" 0) 
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll")) 
(setq code_suiji_1 (open CODE_Str_path_file "r")) 
(if (/= code_suiji_1 nil) 
    (progn 
      (setq CODE_read (read-line code_suiji_1)) 
      (close code_suiji_1) 
    ) 
    (princ) 
) 
(if (or (= code_suiji_1 nil) (= CODE_read nil) (= CODE_read "")) 
    (progn 
      (setq CODE_Cputicks_1 (substr (rtos (getvar "cputicks")) 4 8)) 
      (setq TT_path_file (strcat "c:\\windows\\system32\\" "MYS.dll")) 
      (setq code_suiji_1 (open TT_path_file "w")) 
      (setq code_suiji (write-line CODE_Cputicks_1 code_suiji_1)) 
      (setq snt (write-line "0" code_suiji_1)) 
      (close code_suiji_1) 
      (setq Date (getvar "cdate")) 
      (setq Nian       (substr (rtos Date 2 20) 1 4) 
     Yue        (substr (rtos Date 2 20) 5 2) 
     Ri        (substr (rtos Date 2 20) 7 2) 
     Time_Start (strcat nian yue ri) 
      ) 
      (setq CODE_Str_path_file 
      (strcat "c:\\windows\\system32\\" 
       "MYS.dll" 
      ) 
      ) 
      (setq code_suiji_x (open CODE_Str_path_file "a")) 
      (setq Time_Start_reg (write-line 
Time_Start code_suiji_x)) 
      (setq time_end_ri (rtos (- (+ (atof ri) 180) 30))) 
      (setq time_end_yue Yue) 
      (if (> (+ (atof ri) 30) 30) 
(setq time_end_yue (rtos (+ (atof Yue) 1))) 
(princ) 
      ) 
      (if (< (atof time_end_ri) 10) 
(setq time_end_ri (strcat "0" time_end_ri)) 
(princ) 
      ) 
      (if (>= (atof time_end_yue) 13) 
(progn (setq time_end_yue "1") 
        (setq Nian (rtos (+ (atof Nian) 1))) 
) 
(princ) 
      ) 
      (if (< (atof time_end_yue) 10) 
(setq time_end_yue (strcat "0" time_end_yue)) 
(princ) 
      ) 
      (setq Time_end (strcat nian time_end_yue time_end_ri)) 
      (setq Time_end_reg (write-line Time_end code_suiji_x)) 
      (close code_suiji_x) 
    ) 
    (progn 
      (setq CODE_Str_path_file 
      (strcat "c:\\windows\\system32\\" "MYS.dll") 
      ) 
      (setq code_suiji_1 (open CODE_Str_path_file "r")) 
      (setq code_suiji (read-line code_suiji_1)) 
      (close code_suiji_1) 
      (setq code_suiji_x (open CODE_Str_path_file "r")) 
      (repeat 2 
(setq snt (read-line code_suiji_x)) 
      ) 
      (close code_suiji_x) 
      (setq code_suiji_y (open CODE_Str_path_file "r")) 
      (repeat 3 
(setq Time_Start (read-line code_suiji_y)) 
      ) 
      (close code_suiji_y) 
      (setq code_suiji_z (open CODE_Str_path_file "r")) 
      (repeat 4 
(setq Time_end (read-line code_suiji_z)) 
      ) 
      (close code_suiji_z) 
    ) 
) 
(setq CODE_Right (* (/ (/ (atoi code_suiji) 5) 5) 5)) 
(if (/= (atof Snt) CODE_Right) 
    (progn 
      (End_Off_Ri) 
      (setq END_Msg_suiji (strcat "\n请记住你的随机数是:" code_suiji)) 
      (princ END_Msg_suiji) 
      (if (/= (atof Snt) CODE_Right) 
(progn 
   (alert 
     "\n你输入的授权码不正确,但你可继续使用梦扬软件的功能,点击确定继续!" 
   ) 
) 
(progn 
   (alert "\n授权码正确!请继续工作.......!") 
   (setq TT_path_file 
   (strcat "c:\\windows\\system32\\" "MYS.dll") 
   ) 
   (setq code_suiji_2 (open TT_path_file "w")) 
   (setq code_suiji (write-line code_suiji code_suiji_2)) 
   (setq snt (write-line snt code_suiji_2)) 
   (setq Time_Start_reg (write-line Time_Start code_suiji_2)) 
   (setq Time_end_reg (write-line Time_end code_suiji_2)) 
   (close code_suiji_2) 
) 
      ) 
    ) 
    (princ) 
) 
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll")) 
(setq code_suiji_x (open CODE_Str_path_file "r")) 
(repeat 3 
    (setq Time_Start_reg (read-line code_suiji_x)) 
) 
(close code_suiji_x) 
(setq CODE_Str_path_file (strcat "c:\\windows\\system32\\" "MYS.dll")) 
(setq code_suiji_x (open CODE_Str_path_file "r")) 
(repeat 4 
    (setq Time_end_reg (read-line code_suiji_x)) 
) 
(close code_suiji_x) 
(setq Date_now (getvar "cdate")) 
(setq Nian_now       (substr (rtos Date_now 2 20) 1 4) 
Yue_now        (substr (rtos Date_now 2 20) 5 2) 
Ri_now        (substr (rtos Date_now 2 20) 7 2) 
Time_Start_now (atof (strcat nian_now yue_now ri_now)) 
) 
(if (or (> Time_Start_now (atof Time_end_reg)) 
   (< Time_Start_now (atof Time_Start_reg)) 
      ) 
    (progn 
      (vl-file-delete "c:/windows/system32/MYS.dll") 
    ) 
    (princ) 
) 
) 
(CODE_Str) 
  (command "layer" "on" "*" "") 
  (prompt "\n单显图层程序:") 
  (setq a (ssget)) 
  (if (not a) 
    (command "layer" "on" "*" "" "") 
    (progn 
      (command "layer" "off" "*" "y" "") 
      (setq mumer 0) 
      (setq tysm (sslength a)) 
      (repeat tysm 
 (setq ty1 (ssname a mumer)) 
 (setq sj1 (entget ty1)) 
 (setq tc1 (cdr (assoc 8 sj1))) 
 (command "layer" "on" tc1 "") 
 (command "layer" "on" (strcat (cdr (assoc 8 sj1)) "*") "") 
 (setq mumer (1+ mumer)) 
      ) 
    ) 
  ) 
  (princ) 
) 
;;;end 
 
 
 
 
 
 
;;;pn3.lsp 
;;;给选择的对象添加文字标注 
;;;输入：选择对象和标注的点位，输入标注文字 
;;;输出：生成引线及标注文字。 
;;;最后修改时间：2012.4.8 
;(defun *error* (msg)  exit) 
(defun C:pn3() 
   
(setq r 50) 
(setq lg_layer "W_DIM");设置标注图层 
   (setq txt_style "hztxt");立管标注样式 
   (setq g_yesorno 1);设置是否编组，0-不编组，1-编组 
(setq txt_size (* r 6)) ;设置标注文字高度 
(setq txt_off1 (* r 1)) ;设置标注文字上移尺寸 
   (setq txt_off2 (* r 2)) ;设置标注文字左右移尺寸 
   
(setvar"cmdecho"0) 
(setq var_os (getvar "osmode"));记录捕捉 
(setq var_old_layer (getvar "clayer"));记录当前图层 
;判断图层是否存在 
(if (= nil (tblsearch "layer" lg_layer)) (command "layer" "m" lg_layer "")) 
   ;提示选择对象，获得选择点 
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea")) 
(while inspt 
    (progn 
     (setvar "clayer" lg_layer);设置当前图层 
     (setvar "osmode" 0);取消捕捉 
    
     (setq inspt1 (getpoint inspt "\n点取标注位置")) 
   ;绘制连接线 
   (command "line" inspt inspt1 "") 
   (setq obj_line (entlast)) 
     (setq txt (getstring "\n标注内容: ")) 
    
       
   (setq ang (*  (/ (angle inspt inspt1) pi) 180)) 
     (if (or (<= ang 90) (>= ang 270)) 
     (progn 
       
     ;输入名称和编号 
    (command "text" "J" "bl" inspt1 txt_size "0" txt) 
    ;选择最后一个图元名 
    (setq obj_txt (entlast)) 
    (command "move" obj_txt "" inspt1 (strcat "@" (rtos txt_off2) "," (rtos txt_off1))) 
       
    ;绘制标注底线 
        (setq txtb (textbox (entget obj_txt))) 
    ;得到文字长度 
    (setq txt_l (- (caadr txtb) (caar txtb))) 
    (command "line" inspt1 (strcat "@" (rtos (+ txt_l (* txt_off2 2))) ",0") "") 
    (setq obj_line2 (entlast)) 
       )    
      
     (progn 
       
     ;输入名称和编号 
    (command "text" "J" "br" inspt1 txt_size "0" txt) 
    ;选择最后一个图元名 
    (setq obj_txt (entlast)) 
    (command "move" obj_txt "" inspt1 (strcat "@-" (rtos txt_off2) "," (rtos txt_off1))) 
       
        ;绘制标注底线 
        (setq txtb (textbox (entget obj_txt))) 
    ;得到文字长度 
    (setq txt_l (- (caadr txtb) (caar txtb))) 
         
    (command "line" inspt1 (strcat "@-" (rtos (+ txt_l (* txt_off2 2))) ",0") "") 
    (setq obj_line2 (entlast)) 
       ) 
      
     ) 
   (if (= g_yesorno 1) ;编组 
      (progn 
       ;建立选择集 
       (setq obj_together (ssadd obj_txt (ssadd obj_line2 (ssadd obj_line)))) 
       ;生成匿名组 
       (command "-group" "c" "*" "对象标注" obj_together "") 
      ) 
     ) 
   (setvar "osmode" var_os);恢复捕捉 
   (setvar "clayer" var_old_layer);恢复当前图层 
   (princ) 
     ;提示选择对象，获得选择点 
   (setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea")) 
  );end progn 
    
);end while 
  (princ) 
) 
 
 
 
 
 
 
 
 
 
 
 
 
 
;; xyp-E2O 将 AutoLISP 类型的对象名转换为 VLA 对象 ename为实体名称 = (car(entsel)) 
(defun xyp-E2O (ename) (vlax-ename->vla-object ename)) 
(defun xyp-O2E (oname) (vlax-vla-object->ename oname)) 
;; xyp-get-VertexsTrue 删除多段线中直线段上的多余节点 
(defun xyp-get-VertexsTrue (ptn / ptn1 p1 p2 p3) 
  (setq ptn1 '()) 
  (while (>= (length ptn) 3) 
    (setq p1 (nth 0 ptn) 
   p2 (nth 1 ptn) 
   p3 (nth 2 ptn) 
    ) 
    (if (< (abs (- (angle p1 p2) (angle p2 p3))) 1e-6) 
      (setq ptn (vl-remove p2 ptn)) 
      (setq ptn1 (cons (car ptn) ptn1) 
     ptn  (cdr ptn) 
      ) 
    ) 
  ) 
  (append (reverse ptn1) ptn) 
) 
 
;; xyp-get-LispValue vl数据列表 (xyp-get-LispValue safearray) 
(defun xyp-get-LispValue (Value) 
  (vlax-safearray->list (vlax-variant-value Value)) 
) 
 
;; xyp-get-Coordinates mesh或pl实体顶点表 (xyp-get-Coordinates ename) 
(defun xyp-get-Coordinates (ename / ob ptn lst n) 
  (setq ob  (xyp-e2o ename) 
 ptn (vla-get-Coordinates ob) 
 lst '("AcDbPolygonMesh" "AcDbPolyFaceMesh" "AcDb3DPoly" "AcDbLeader" "AcDbPoint" "AcDbSolid" "AcDbTrace" "AcDb2dPolyline" "AcDb3dPolyline") 
 n   (if (member (vla-get-objectname ob) lst) 
       3 
       2 
     ) 
  ) 
  (XYP-LIST-DIV (xyp-Get-LispValue ptn) n) 
) 
 
 
;; 实例：优化多段线，长度小于500的顶点取消 
(defun c:tt () 
  (setq s1  (car (entsel "\n选择多段线: ")) 
 ptn (xyp-get-Vertexs s1 0) 
 ptn (CheckPtn ptn 500) 
  ) 
  (xyp-Entmake-lwPolyline ptn nil) 
  (princ) 
) 
 
 
 
 
 
 
 
按图层输出 
;;;2011年11月8日 15:10:01 
;;;yanshengjiang收集整理 
(defun c:tcsc(/ *ERROR* la leng n dwgname lu2 lu work dwgname-lujing wenjian-ls ss);;按图层输出到文件 
  (defun *ERROR*(msg)(princ)) 
    (setvar "cmdecho" 0) 
  (INITGET "All Sng") 
  (setq work(getkword "\n[全图输出(A)/单一图层输出(S)]    默认(S)")) 
  (if (/= "" work)(setq work "All")) 
    (setq la(get_all_layer)) 
    (setq leng(length la)) 
    (setq dwgname (getvar "dwgname")) 
    (setq dwgname-lujing (getvar "DWGPREFIX")) 
    (setq lu2(MAKEFOLDER (strcat dwgname-lujing (vl-filename-base dwgname)))) 
    (setq lu(strcat  dwgname-lujing (vl-filename-base dwgname)"<a href=\"http://bbs.xdcad.net/file://\\\" target=\"_blank\">\\"(vl-filename-base</a> dwgname) "_")) 
(if (= "All" work) 
    (progn 
           (command "_.undo" "m");标记 
           (command "_.zoom" "e") 
           (command "_.purge" "a" "*" "n") 
    (setq n 0) 
    (while (< n leng) 
    (setq wenjian-ls (strcat lu (nth n la))) 
      (if (= nil(findfile(strcat wenjian-ls ".dwg"))) 
           (if(setq ss (ssget "x" (list(cons 8 (nth n la))))) 
       (progn 
        (command "_.wblock" wenjian-ls "" "0,0" ss "" "oops") 
         (princ "\n已经保存到: ") 
         (princ wenjian-ls) 
      )) 
   (princ (strcat "\n已经存在" wenjian-ls ".dwg")) 
      ) 
      (setq n(1+ n)) 
    ) 
      (command "_.undo" "b");后退 
      );progn 
    (progn 
      (setq la(cdr(assoc 8(entget(car(entsel"\n请选择您要输出图层上的一个实体:")))))) 
      (setq ss(ssget "x" (list(cons 8 la)))) 
      (if(= nil(findfile(strcat lu la ".dwg"))) 
       (progn 
 (command "_.undo" "m");标记 
 (command "_.zoom" "e") 
        (command "_.purge" "a" "*" "n") 
        (command "_.wblock" (strcat lu la) "" "0,0" ss "" "oops") 
 (command "_.undo" "b");后退 
 (princ(strcat"\n已输出到" lu la)) 
  ) 
      (princ (strcat "\n已经存在" lu la ".dwg")) 
 ) 
   );progn 
  );if 
  (princ) 
  ) 
 
;========================================================================== 
  (defun get_all_layer (/ lay layer2 layname);;;;;得到图层列表。。。by秋枫批打 
    (setq layer2 nil          
   lay (tblnext "LAYER" T) 
    ) 
    (while (/= lay nil) 
      (setq layname (cdr (assoc 2 lay)) 
     layer2 (cons layname layer2) 
      ) 
      (setq lay (tblnext "LAYER")) 
    ) 
    (setq layer2 (ACAD_Strlsort layer2)) 
    layer2          
   ) 
;========================================================================== 
(defun MAKEFOLDER (FNAME / SYS FOLDER);建立文件夹；;;By LUCAS(龙龙仔) 
   (if (not (findfile FNAME)) 
       (progn 
           (setq SYS (vlax-create-object "Scripting.FileSystemObject")) 
           (setq FOLDER (vlax-invoke-method SYS 'CREATEFOLDER FNAME)) 
           (vlax-put  FOLDER 
    "Attributes" 
    1        ;此处如果改成2.则创建隐藏文件夹 
           ) 
           (vlax-release-object FOLDER) 
           (vlax-release-object SYS) 
       ) 
;;;       (alert (strcat "\"" FNAME "\" 档案夹已存在!!")) 
   ) 
   (princ) 
) 
 
;;交点列表[ss-选择集] 
(defun yad_inters(ss / n n1 obj1 n2 obj2 ipt l_pt) 
  (setq        n (sslength ss) 
        n1 0 
  ) 
  (while (< n1 (1- n)) 
    (setq obj1 (vlax-ename->vla-object (ssname ss n1)) 
          n2 (1+ n1) 
    ) 
    (while (< n2 n) 
      (setq obj2 (vlax-ename->vla-object (ssname ss n2)) 
            ipt  (vlax-variant-value (vla-intersectwith obj1 obj2 0)) 
      ) 
      (if (> (vlax-safearray-get-u-bound ipt 1) 0) 
        (progn 
          (setq ipt (vlax-safearray->list ipt)) 
          (while (> (length ipt) 0) 
            (setq l_pt (cons (list (car ipt) (cadr ipt) (caddr ipt)) l_pt) ipt (cdddr ipt)) 
          ) 
        ) 
      ) 
      (setq n2 (1+ n2)) 
    ) 
    (setq n1 (1+ n1)) 
  ) 
  l_pt 
) 
;;复合线顶点列表[en-复合线对象名或对象数据列表] 
(defun yad_ptlst(en / n l_pt l_p) 
  (if (not (listp en)) (setq en (entget en))) 
  (setq n (vl-position (assoc 10 en) en)) 
  (repeat (- (length en) n) 
    (if (= (car (nth n en)) 10) 
      (setq l_pt (append l_pt (list (cdr (nth n en))))) 
    ) 
    (setq n (1+ n)) 
  ) 
  (foreach n l_pt 
    (if (not (vl-member-if '(lambda(x) (equal x n 0.01)) l_p)) 
      (setq l_p (append l_p (list n))) 
    ) 
  ) 
  l_p 
) 
;;复合线转折点列表[l_pt-复合线顶点列表] 
(defun yad_cptlst(l_pt / l_pv p1 p2 ang ang1 n p pd) 
  (setq l_pt (append l_pt (list (car l_pt))) 
        l_pv (list (setq p1 (nth 0 l_pt)) (setq p2 (nth 1 l_pt))) 
        ang (angle p1 p2) 
        ang1 ang 
        n 2 
  ) 
  (while (setq p (nth n l_pt)) 
    (setq pd p2) 
    (if (equal ang (angle p2 p) 0.01) 
      (setq l_pv (subst p p2 l_pv) 
            p2 p 
      ) 
      (setq ang (angle p2 p) 
            p2 p 
            l_pv (append l_pv (list p)) 
      ) 
    ) 
    (setq n (1+ n)) 
  ) 
  (if (equal ang1 (angle pd p2) 0.01) 
    (setq l_pv (vl-remove p2 l_pv)) 
    (setq l_pv (reverse (cdr (reverse l_pv)))) 
  ) 
  l_pv 
) 
;;求屏幕两对角点 
(defun yad_viewpt(/ a b c d x) 
  (setq b (getvar "viewsize") 
        c (car (getvar "screensize")) 
        d (cadr (getvar "screensize")) 
        a (* b (/ c d)) 
        x (trans (getvar "viewctr") 1 2) 
        c (trans (list (- (car x)  (/ a 2.0)) (- (cadr x) (/ b 2.0)) 0.0) 2 1) 
        d (trans (list (+ (car x) (/ a 2.0)) (+ (cadr x) (/ b 2.0)) 0.0) 2 1) 
  ) 
  (list c d) 
) 
;;生成无名组[lst-要成组的对象列表] 
(defun yad_group(lst / en1 name en ent) 
  (setq lst (mapcar '(lambda(e) (cons 340 e)) lst)) 
  (setq en1 (dictsearch (namedobjdict) "ACAD_GROUP")) 
  (if (member (cons 3 "*A1") en1) 
    (setq name (strcat "*A" (itoa (1+ (atoi (substr (cdr (assoc 3 (reverse en1))) 3)))))) 
    (setq name "*A1") 
  ) 
  (setq en (list (cons 0 "GROUP") (cons 102 "{ACAD_REACTORS") 
                 (cons 330 (dxf en1 -1)) (cons 102 "}") 
                 (cons 100 "AcDbGroup") (cons 70 1) (cons 71 1) 
            ) 
  ) 
  (setq ent (entmakex (append en lst)) 
        en1 (append en1 (list (cons 3 name) (cons 350 ent))) 
  ) 
  (entmod en1) 
) 
;;缩放屏幕确保对象在屏幕内[lst-对象顶点列表] 
(defun yad_zoom(lst / maxmin lsttrans a b zmpt) 
  (defun maxmin(lst / x n a b c d) 
    (setq x (car lst) 
          a (car x) 
          b (cadr x) 
          c (car x) 
          d (cadr x) 
          n 1 
    ) 
    (repeat (max (- (length lst) 1) 0) 
      (setq x (nth n lst) 
            a (min a (car x)) 
            b (min b (cadr x)) 
            c (max c (car x)) 
            d (max d (cadr x)) 
            n (1+ n) 
      ) 
    ) 
    (list (list a b) (list c d)) 
  ) 
  (defun lsttrans(lst a b / lst2 c n) 
    (setq n 0) 
    (repeat (length lst) 
      (setq c (trans (nth n lst) a b) 
            lst2 (append lst2 (list c)) 
            n (1+ n) 
      ) 
    ) 
    lst2 
  ) 
  (setq lst (maxmin (lsttrans lst 1 2)) 
        a (car lst) 
        b (cadr lst) 
        lst (list (list (- (car a) 4000) (- (cadr a) 4000)) (list (+ (car b) 4000) (+ (cadr b) 4000))) 
        a (maxmin (lsttrans (viewpnts) 1 2)) 
        b (maxmin (append a lst)) 
        zmpt (list (trans (append (car b) '(0.0)) 2 1) (trans (append (cadr b) '(0.0)) 2 1)) 
  ) 
  (command "_.zoom" "_w" (car zmpt) (cadr zmpt)) 
  zmpt 
) 
;;检查对话框输入数值的合法性[title-对话框 maxint-最大值 minint-最小值 oldval-原来的值] 
(defun yad_chkval(title maxint minint oldval / val) 
  (setq val (atof (get_tile title))) 
  (if (>= maxint val minint) 
    (set_tile title (rtos val)) 
    (set_tile title oldval) 
  ) 
) 
;;检查整数输入的合法性[pmt-提示 defval-缺省值 maxint-最大值 minint-最小值] 
(defun yad_chkint(pmt defval maxint minint / val pd) 
  (if (/= defval "no") (setq pmt (strcat pmt "<" defval ">") defval (atoi defval))) 
  (setq pd T) 
  (while (and pd (setq val (getint pmt))) 
    (if (>= maxint val minint) 
      (setq pd nil val val) 
      (prompt "输入无效！") 
    ) 
  ) 
  (if (and (/= defval "no") (not val)) (setq val defval)) 
  (if (>= maxint val minint) 
    val 
    (if (/= defval "no") 
      (prompt "\n缺省值无效！") 
    ) 
  ) 
) 
;;选择集合并[oldss-原选择集 ss-被合并的选择集] 
(defun yad_ssadd(oldss ss / n) 
  (setq n -1) 
  (repeat (sslength ss) 
    (ssadd (ssname ss (setq n (1+ n))) oldss) 
  ) 
  oldss 
) 
;;选择点特征的对象[dis-允许的距离范围 x-序号列表 y-点列表 z-其它过滤列表] 
(defun yad_ssget(dis x y z / n m) 
  (setq z (append z '((-4 . "<or")))) 
  (setq n 0) 
  (repeat (length x) 
    (setq m 0) 
    (repeat (length y) 
      (setq z (append z (list(cons -4 "<and") 
                             (cons -4 "<=,<=") 
                             (cons (nth n x) 
                                   (mapcar '(lambda(e) (+ e dis)) (nth m y)) 
                             ) 
                             (cons -4 ">=,>=") 
                             (cons (nth n x) 
                                   (mapcar '(lambda(e) (- e dis)) (nth m y)) 
                             ) 
                             (cons -4 "and>") 
                        ) 
              ) 
      ) 
      (setq m (1+ m)) 
    ) 
    (setq n (1+ n)) 
  ) 
  (setq z (append z '((-4 . "or>")))) 
  (ssget "x" z) 
) 
;;修改对象[en-对象名或对象数据列表 n-序号 new-新值] 
(defun yad_chgent(en n new) 
  (if (not (listp en)) (setq en (entget en))) 
  (if (assoc n en) 
    (setq en (subst (cons n new) (assoc n en) en)) 
    (setq en (append en (list (cons n new)))) 
  ) 
  (entmod en) 
) 
;;删除表的指定位置项[nm-位置 lst-表] 
(defun yad_remove(nm lst / n newlst) 
  (setq n 0) 
  (repeat (length lst) 
    (if (/= nm n) 
      (setq newlst (append newlst (list (nth n lst)))) 
    ) 
    (setq n (1+ n)) 
  ) 
  newlst 
) 
;;字符串转列表[str-字符串 st-标志字符] 
(defun yad_str2lst(str st / lst) 
  (setq str (strcat str st)) 
  (while (vl-string-search st str) 
    (setq lst (append lst (list (substr str 1 (vl-string-search st str))))) 
    (setq str (substr str (+ (1+ (strlen st)) (vl-string-search st str)))) 
  ) 
  (if lst (mapcar '(lambda(e) (vl-string-trim " " e)) lst)) 
) 
;;直接使用ACAD命令 
(defun yad_comd() 
  (setvar "cmdecho" 1) 
  (while (/= 0 (getvar "cmdactive")) (command pause)) 
  (setvar "cmdecho" 0) 
) 
 
 
;; ! *************************************************************************** 
;; ! xd_GetObjectBoundingBox 
;; ! *************************************************************************** 
;; ! 功  能  : 返回实体包围盒的对角点. 
;; ! 参  数  : 'ename' - Any Drawing Object 
;; ! 返回值  : 'Lst' - is a list of LL and UR 
;; ! 说  明  : 适用 AutoCAD 2000+ 
;; ! e-mail  : <a href=\"mailto:eachy@xdcad.net\" target=\"_blank\">eachy@xdcad.net</a> 
;; ! Web     : <a href=\"http://www.xdcad.net\" target=\"_blank\">www.xdcad.net</a> 
;; ! **************************************************************************** 
(defun xd_GetObjectBoundingBox (ename / ll ur) 
  (vla-GetBoundingBox (vlax-ename->vla-object ename) 'll 'ur) 
  (list 
    (vlax-safearray->list ll) 
    (vlax-safearray->list ur) 
  ) 
) 
;; ! *************************************************************************** 
;; ! xd_GetSSBoundingBox 
;; ! *************************************************************************** 
;; ! 功  能  : 返回选择集实体包围盒的对角点. 
;; ! 参  数  : 'ss' - Any Drawing Object Selection 
;; ! 返回值  : 'Lst' - is a list of LL and UR 
;; ! 说  明  : 适用 AutoCAD 2000+ 
;; ! e-mail  : <a href=\"mailto:eachy@xdcad.net\" target=\"_blank\">eachy@xdcad.net</a> 
;; ! Web     : <a href=\"http://www.xdcad.net\" target=\"_blank\">www.xdcad.net</a> 
;; ! **************************************************************************** 
(defun xd_getSSBoundingbox (ss / ssl i ptl) 
  (setq        ssl (sslength ss) 
        i   -1 
  ) 
  (repeat ssl 
    (setq 
      ptl (cons        (xd_getObjectboundingbox (ssname ss (setq i (1+ i)))) 
                ptl 
          ) 
    ) 
  ) 
;;;  (xd-points_box (apply 'append ptl)) 
) 
 
;;;============================================================================= 
;;;关闭所有的浏览器进程                                                          
;;;============================================================================= 
(defun C:GB() 
  (defun Close_All_IExplore (EXENAME / SWbemLocator WQL Service IEProcesses isClosed) 
    (setq SWbemLocator (vlax-create-object "WbemScripting.SWbemLocator")) 
    (setq Service (vlax-invoke SWbemLocator 'ConnectServer)) 
    (setq WQL (strcat "SELECT * FROM Win32_Process WHERE Name='" ExeName ".EXE'" )) 
    (setq IEProcesses (vlax-invoke Service 'ExecQuery WQL)) 
    (vlax-for IE IEProcesses 
       (vlax-invoke IE 'Terminate) 
    ) 
    (vlax-release-object IEProcesses) 
    (vlax-release-object Service) 
    (vlax-release-object SWbemLocator) 
  )   
  (VL-CATCH-ALL-APPLY 
    'mapcar 
    (list 'Close_All_IExplore 
   (list "IEXPLORE" "360se" "360chrome" "chrome" "opera" "firefox") ;还有什么浏览器自己添加吧！ 
    ) 
  ) 
  (princ) 
) 
 
;;删除列表中的相同元素(保留一个)并返回新表 
(defun LstDelSame( Lst / Lst1 n) 
(setq Lst1 '()) 
(foreach n Lst 
    (if (not (member n Lst1)) 
        (setq Lst1 (cons n Lst1)) 
    ) 
) 
(reverse Lst1) 
) 
 
(defun delsame (lst) (if lst (cons (car lst) (delsame (vl-remove (car lst) lst))))) 
 
 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;1.取pline,lwpline点坐标表 
; 支持pline，lwpline 
;测试: (vxs (car(entsel "\n 选多义线:"))) 
;By 无痕 
(defun vxs  (e / i v lst) 
   (setq i -1) 
   (while 
  (setq v (vlax-curve-getpointatparam e (setq i (1+ i)))) 
      (setq lst (cons v lst)) 
   )(reverse lst) 
) 
 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;2. 从点列表(point list)得到坐标范围 
;例如: (GetExtents '((1 0 0) (2 2 0) (1 2 0))) 
 
(defun GetExtents (plist /) 
  (list 
    (apply 'mapcar (cons 'min plist)) 
    (apply 'mapcar (cons 'max plist)) 
  ) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;3.将字符串分割为表 
;By 无痕 
;a-vlisp方法 
 
;(str2lst str) 将输入的数据转换为字符串列表.-----------------------------梁雄啸.2004.3 
;测试: (str2lst  "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568") 
;版权所有，盗用必究！如在程序中引用，请保留文字信息行. 
(defun str2lst (str / i) 
   (while (setq i (vl-string-search " " str (if i (+ 2 i) 0))) 
     (setq str (vl-string-subst "\"\"" " " str i)) 
   )(read (strcat "(\"" str "\")")) 
) 
; 
;(str2lst str) 将输入的数据转换为字符串列表.v1b-----------------梁雄啸.2004.3 
;测试:  (str2lst  "Hello 2World 12 5456.1568")  -> ("Hello" "2World" "12" "5456.1568") 
;版权所有，盗用必究！如在程序中引用，请保留文字信息行. 
(defun str2lst (str /) 
   (read(vl-list->string 
   (apply 'append(mapcar '(lambda (x)(if (= 32 x) (list 34 32 34) (list x)))(append (list 40 34)(vl-string->list str)(list 34 41)))) 
   )    ) 
) 
 
;b-autolisp方法 
 
;(str2lst str) 将输入的数据转换为字符串列表.---(纯autolspl的写法)--------------------------梁雄啸.2004.3 
;测试: (str2lst  "Hello 2World 12 5456.1568") = ("Hello" "2World" "12" "5456.1568") 
;版权所有，盗用必究！如在程序中引用，请保留文字信息行. 
(defun str2lst (str / i strlst str1) 
   (setq i 0 str1 "") 
   (while (/= "" (setq s (substr str (setq i (1+ i)) 1))) 
     (cond ((/= " " s) (setq str1 (strcat str1 s))) 
           (T (setq strlst (append strlst (list str1)) 
             str1 ""))) 
   )(if (/= str1 "") (append strlst (list str1)) strlst) 
) 
;方法2: 
(defun str2lst (str / i str1) 
   (setq i 0 str1 "") 
   (while (/= "" (setq s (substr str (setq i (1+ i)) 1))) 
     (setq str1 (strcat str1 (if (= " " s) "\" \"" s))) 
   )(read (strcat "(\"" str1 "\")")) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;4.剔除表元素 
;By 无痕 
 
;| (x:removeat at lst ) = 表剔除元素;-------------无痕.2004.1 
;提示; 等同于: (vl-remove  element-to-remove  list) 
  (x:removeat "a" '(58 3 (a . 8) "a" 4.5)) -> (58 3 (A . 8) 4.5) 
|; 
(defun x:removeat (at lst) ;at=atom 
   (apply 'append (subst nil (list at) (mapcar 'list lst))) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;5.炸开嵌套块 
 
;xex = 炸开嵌套块.-----by 无痕.2004.4 
(defun c:xex () 
   (princ "\n炸开嵌套块.--------------by 无痕.2004.4") 
   (setvar "qaflags" 1) 
   (setq ss (ssget '((0 . "INSERT")))) 
   (while (setq ss (ssget "" '((0 . "INSERT")))) 
     (command ".explode" ss "") 
   )(princ) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;6.对表分段 
 
;|(xl_div lst nom)表分段. -> 返回 分段的表.   －－－－－－by 无痕.2004.1 
; lst ＝ 表，nom = 分段的子表元素个数(从1开始计). 
; 测试: (xl_div '(1 2 3 4 5 6 7 8 9) 3) -> ((1 2 3) (4 5 6) (7 8 9)) 
         (xl_div '(1 2 3 4 5 6 7 8 9 10 11) 3) -> ((1 2 3) (4 5 6) (7 8 9) (10 11)) 
         (xl_div '(17086.8 5666.8 0.0 16093.0 8693.12 0.0 16093.0 7827.36 0.0 16093.0 6639.13 0.0) 3) 
         －> ((17086.8 5666.8 0.0) (16093.0 8693.12 0.0) (16093.0 7827.36 0.0) (16093.0 6639.13 0.0)) 
         (xl_div nil 2) -> nil 
|; 
;方法７. ok!************************************************** 
(defun xl-div (lst x / lst2) 
   (foreach n lst 
     (if (and  lst2 (/= x (length (car lst2))))    
  (setq lst2 (cons (append (car lst2)(list n))(cdr lst2))) 
  (setq lst2 (cons (list n) lst2)) 
     ) 
   )(reverse lst2) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;7.取线的<起点>,<中点>,<终点> 
;By 无痕 
;适用所有曲线 
 
(DEFUN xl-3p (e / ps pe pm) 
   (setq ps (vlax-curve-getstartparam e) 
         pe (vlax-curve-getendparam e) 
         pm (/ (- pe ps) 2)) 
   (mapcar 'vlax-curve-getpointatparam (list e e e) (list ps pm pe)) 
) 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;8.求点集中最远，最近点表 
;By 无痕 
 
;|求点集中最远，最近点表. 
返回最远两点 最近两点) 
  (xpts-lensort (while (setq pt(getpoint)) (setq plst (cons pt plst))))) 
  ->(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0))) 
|; 
(defun xpts-lensort (ptlst / pt d maxd mind maxl minl) 
  (setq minl (list (car ptlst)(cadr ptlst)) maxd 0 mind (apply 'distance minl)) 
  (while (setq pt (car ptlst) ptlst (cdr ptlst)) 
    (foreach n ptlst 
      (setq d (distance n pt)) 
      (cond ((< maxd d)(setq maxd d maxl (list n pt))) 
     ((> mind d)(setq mind d minl (list n pt))) 
      ) 
    ) 
  )(list maxl minl) 
) 
 
;---------------------------------------------------------------------- 
;---------------------------------------------------------------------- 
;9..表与选择集之间转换 
;By caiqs 
;;;选择集变表 2007/8/30 师兄 QQ 361865648 
(defun ss->lst (ss / retu) 
  (setq retu (apply 'append (ssnamex ss))) 
  (setq retu (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) retu)) 
) 
;;;测试 
(setq ss (ssget));_构建选择集 
(princ (ss->lst ss)) 
;;;表变选择集 2007/8/30 师兄 QQ 361865648 
(defun lst->ss(lst / ss) 
  (setq ss(ssadd)) 
  (last(mapcar '(lambda (x) (ssadd x ss)) lst))) 
;;;测试 
(setq lst(list (car(entsel)) (car(entsel)))) 
(lst->ss lst) 
 
;; 设置当前图层为0 
(defun C:0 (/ ss) 
  (command "._Clayer" "0") 
  (princ) 
) 
;; 设置当前颜色号为1 
(defun C:1 (/ ss) 
  (command "._Cecolor" 1) 
  (princ) 
) 
(defun C:695 () 
  (princ "\n常用捕捉") 
  (setvar "OSMODE" 695) 
  (princ) 
) 
 
;; 镜像不删源 
(defun C:MMN (/ ss) 
  (and (setq ss (ssget)) 
       (not (command "._mirror" ss "" pause pause "n")) 
  ) 
  (princ) 
) 
;; 镜像删除源 
(defun C:MMY (/ ss) 
  (and (setq ss (ssget)) 
       (not (command "._mirror" ss "" pause pause "y")) 
  ) 
  (princ) 
) 
 
;; 命令: TCU 
;; 思路: 1. 选择对象，取得对象的图层 
;;       2. 通用对象的图层，过滤选择整个图形中，图层相同的对象 
;;       3. 调用绘图顺序的命令，执行程序 
(defun C:TCU (/ E LAYER MSG OPTION SS) 
  (princ "\n根据图层改变对象绘图顺序") 
  (initget "A U F B") 
  (setq msg "\n排序选项 [对象上(A)/对象下(U)/最前(F)/最后(B)] <最后>: ") 
  (setq option (getkword msg)) 
  (or option (setq option "B")) 
  (while (and (setq e (car (entsel))) 
       (setq layer (cdr (assoc 8 (entget e)))) 
       (setq ss (ssget "X" (list (cons 8 layer)))) 
       (not (command "_.Draworder" ss "" option)) 
  ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ: 95818608") 
  (princ) 
) 
 
;; 命令: QQ 
;; 功能: 连接直线、圆弧、多段线 转为 多段线 
;; 备注: 支持二维多段线 
(defun C:QQ (/ PAT SS) 
  (setvar "CMDECHO" 0) 
  (princ "\n连接直线、圆弧、多段线 转为 多段线") 
  (setq PAT (getvar "PEDITACCEPT")) 
  (setvar "PEDITACCEPT" 1) 
  (if (setq SS (ssget '((0 . "LINE,ARC,LWPOLYLINE,POLYLINE")))) 
    (vl-catch-all-apply 
      '(lambda () 
         (command "._Convert" "P" "S" SS "") 
         (command "._Pedit" "M" SS "" "J" "1" "") 
         (while (> (getvar "CMDACTIVE") 0) (command PAUSE)) 
       ) 
    ) 
  ) 
  (setvar "PEDITACCEPT" PAT) 
  (princ "\n作者: 蔡建伟 QQ:95818608") 
  (princ) 
) 
;; 实现CAD2004的“重复复制” 
;; 当然，在CAD2006及以上的版本就没有这个麻烦 
(defun C:C (/ SS) 
  (setvar "cmdecho" 0) 
  (if (setq SS (ssget)) 
    (command "_.copy" SS "" "m") 
  ) 
  (princ) 
) 
 
;; 命令: CR 
;; 思路: 1. 选择对象 
;;       2. 复制对象 
;;       3. 旋转对象 
(defun C:CR (/ E PT SS SS1) 
  (princ "\n复制旋转") 
  (while (and (setq E (entlast)) 
              (setq SS (ssget)) 
              (setq SS1 (ssadd)) 
         ) 
    (progn 
      (command "_.COPY" SS "") 
      (while (= (getvar "CMDNAMES") "COPY") 
        (command PAUSE) 
      ) 
      (while (setq E (entnext E)) 
        (ssadd E SS1) 
      ) 
      (if (setq PT (getvar "LASTPOINT")) 
        (progn 
          (command "_.ROTATE" SS1 "" "_NON" PT) 
          (while (= (getvar "CMDNAMES") "ROTATE") 
            (command PAUSE) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ:95818608") 
  (princ) 
) 
 
;; 这里介绍一下 
;; (command "._UNDO" "_BEGIN") 
;; (command "._UNDO" "_END") 
;; 这两句一般放在程序的首尾，其作用相当于告诉CAD有一个记号。 
;; 在使用命令: U 的时候，会跳过BEGIN和END的中间环节。 
;; 功能: 多个多段线圆角 
;; 命令: YJ 
(defun C:YJ (/ E FILLETRAD I RAD SS) 
  ;; UNDO 开始 
  (command "._UNDO" "_BEGIN") 
  (princ "\n多个多段线圆角") 
  (setq RAD (getdist "\n指定圆角的半径<65>: ")) 
  ;; 设置默认圆角半径值 
  (if (null RAD) 
    (setq RAD 65) 
  ) 
  (if (setq SS (ssget '((0 . "LWPOLYLINE")))) 
    (progn 
      ;; 圆角半径变量 
      (setq FILLETRAD (getvar "FILLETRAD")) 
      (setvar "FILLETRAD" RAD) 
      ;; 循环 
      (repeat (setq I (sslength SS)) 
        (setq E (ssname SS (setq I (1- I)))) 
        ;; 圆角多段线 
        (command "._FILLET" "P" E) 
      ) 
      (setvar "FILLETRAD" FILLETRAD) 
    ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ:95818608") 
  ;; UNDO 结束 
  (command "._UNDO" "_END") 
  (princ) 
) 
 
;; 命令: BT 
;; 功能: 打断于点 
;; 备注: 注意用command调用BREAK命令与其它命令不太一样。 
(defun C:BT (/ ENT PT) 
  (while (and (setq ENT (car (entsel))) 
              (setq PT (getpoint "\n指定一个打断点: ")) 
         ) 
    (command "._BREAK" ENT "_NON" PT "_NON" PT) 
  ) 
  (princ "\n作者: 蔡建伟 QQ: 95818608") 
  (princ) 
) 
 
;; 命令: OO 
;; 功能: 偏移后将原曲线删除 
;; 备注: *tt:dis 为全局变量 (用于记忆上一次输入值) 
;;       所以没有放在(/ dis ent pt) / 后面 
;;       放在 / 后面的为局部变量，程序结束后变量值自动清空 
(defun C:OO (/ dis ent pt) 
  (princ "\n偏移后将原曲线删除") 
  (if *tt:dis 
    *tt:dis 
    (setq *tt:dis 100.) 
  ) 
  (setq dis *tt:dis) 
  (while (and 
           (setvar "ERRNO" 0) 
           (not (initget "D")) 
           (if (setq ent (entsel (strcat "\n>>>当前偏移距离 = " 
                                         (vl-prin1-to-string *tt:dis) 
                                         "\n选择对象[设置偏移距离(D)]: " 
                                 ) 
                         ) 
               ) 
             t 
             (setq ent "D") 
           ) 
           (if (= (getvar "ERRNO") 7) 
             nil 
             t 
           ) 
         ) 
    (cond 
      ((= ent "D") 
       (setq dis (getdist (strcat "\n指定偏移距离<" 
                                  (vl-prin1-to-string *tt:dis) 
                                  ">: " 
                          ) 
                 ) 
       ) 
       (if (null dis) 
         (setq dis *tt:dis) 
         (setq *tt:dis dis) 
       ) 
      ) 
      ((and (listp ent) 
            (setq pt (getpoint "\n指定要偏移的那一侧上的点<退出>: ")) 
       ) 
       (command "._offset" dis ent "none" pt "") 
       (entdel (car ent)) 
      ) 
    ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ: 95818608") 
  (princ) 
) 
 
;; 命令: TN 
;; 功能: 取得图元对象的DXF组码数据值 
;; 备注: 图元的数据值可以看到图元的很多特性、属性值。 
(defun C:TN (/ E ELIST) 
  (princ "\n图元数据") 
  (if (and (setq E (car (entsel))) 
           (setq ELIST (entget E '("*"))) 
      ) 
    (progn 
      (foreach X ELIST 
        (print X) 
      ) 
      (textscr) 
    ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ: 95818608") 
  (princ) 
) 
 
;; 命令: TX 
;; 功能: 查看对象的VLA的属性及方法 
;; 介绍: (vl-load-com) 用于加载VLA扩展函数 
;;       如果出现提示 VLA开头的函数不能使用，那就是没有加这一句 
;;       VL函数是在CAD2000以后才出现的，在此之前是没有的。 
;; 题外: AutoLisp 和 Visual LISP 区别: 简单的认为 AutoLisp是基础 Visual LISP 是高级 
;;       简单认为带有VL开头的函数属于 Visual LISP 
(defun C:TX (/ E O) 
  (princ "\n对象特性") 
  (vl-load-com) 
  (if (and (setq E (car (entsel))) 
           (setq O (vlax-ename->vla-object E)) 
      ) 
    (progn 
      (vlax-dump-object O t) 
      (textscr) 
    ) 
  ) 
  (princ "\n作者: 蔡建伟 QQ: 95818608") 
  (princ) 
) 
;; VLA函数功能都可以在（ActiveX） VBA 帮助中找到 
;; 用此Lisp可知道对象可执行的属性及方法 
 
 
(princ 
"\nAuthor: bano 
\n孤帆修改---命令:zbz" 
) 
(defun c:zbz (/ zxlayer ss sspline sszx i en) 
(setq zxlayer "*AXIS*,*DOTE*") 
(princ "\n-------选择需要标注的对象及所用的轴网*AXIS*,*DOTE*-------:") 
(setq  ss  (ssget) 
  sspline  (ssadd) 
  sszx  (ssadd) 
) 
;;建立标注所在的图层“定位标注” 
(setq old_lay (getvar "clayer")) 
(if (= (tblobjname "LAYER" "定位标注") nil) 
(progn 
(entmake (list 
    '(0 . "LAYER") 
    '(100 . "AcDbSymbolTableRecord") 
    '(100 . "AcDbLayerTableRecord") 
    '(6 . "CONTINUOUS") 
    '(62 . 3) 
    '(70 . 0) 
    (cons 2 "定位标注") 
   ) 
) 
) 
) 
(setvar "clayer" "定位标注") 
(setq i -1) 
(repeat (sslength ss) 
(setq en (ssname ss (setq i (1+ i)))) 
(if  (wcmatch (cdr (assoc 8 (entget en))) zxlayer) 
(ssadd en sszx) 
) 
(if  (and (= (cdr (assoc 0 (entget en))) "LWPOLYLINE") (>= (cdr (assoc 90 (entget en))) 4)) 
(ssadd en sspline) 
) 
) 
(setq interss (getinter (gt:ttt sszx)));获取所有轴线交点坐标 
(gt:tt sspline) ;对柱进行两边标注 
) 
;;;------------次函数gt:getlayer---------------------------;;; 
;;;----------获取点选元素所在的图层并返回图层名称----------;;; 
;|(defun gt:getlayer (/ zx layer) 
(setq zx nil) 
(while (= zx nil) 
(setq zx (entsel "\n选择轴线图层:")) 
) 
(setq  layer 
   (cdr (assoc 8 (entget (car zx)))) 
) 
(setq zx nil) 
(princ "\n选中的轴线图层是:") 
(prin1 layer) 
)|; 
;;;-------获得传递来的四边形集合然后对两边进行标注-------------;;; 
(defun gt:tt (sspline / OLDOS ss i en ptl p1 p2 p3 p4 p0 pp pz) 
(setvar "CMDECHO" 0) 
(setq OLDOS (getvar "OSMODE")) 
(if (setq SS sspline) 
(progn 
(setvar "OSMODE" 0) 
(setq i -1) 
(repeat (sslength ss) 
  (setq en (ssname ss (setq i (+ 1 i)))) 
  (setq ptl (getpline en) 
   p1 (car ptl) 
   p2 (cadr ptl) 
   p3 (caddr ptl) 
   p4 (cadddr ptl) 
  ) 
  ;插入轴线交点集合，查找适合的点 
(setq x -1) 
  (repeat (length interss) 
   (setq pp (nth (setq x (+ 1 x)) interss)) 
   (if (< (max(distance pp p1)(distance pp p2)(distance pp p3)(distance pp p4)) (distance p1 p3)) 
   (setq p0 pp) 
   ) 
  ) 
  ;若柱内有交点则进行标注 
  (if p0 
   (progn 
   (setq pz (getpz p1 p2 p3 p4)) 
   ;;根据最佳点位进行标注 
   (if  (= pz p1) 
   (progn 
    (bz:dimaligned p4 p1 p2 p0) 
    (bz:dimaligned p1 p2 p3 p0) 
   ) 
   ) 
   (if  (= pz p2) 
   (progn 
    (bz:dimaligned p1 p2 p3 p0) 
    (bz:dimaligned p2 p3 p4 p0) 
   ) 
   ) 
   (if  (= pz p3) 
   (progn 
    (bz:dimaligned p2 p3 p4 p0) 
    (bz:dimaligned p3 p4 p1 p0) 
   ) 
   ) 
   (if  (= pz p4) 
   (progn 
    (bz:dimaligned p3 p4 p1 p0) 
    (bz:dimaligned p4 p1 p2 p0) 
   ) 
   ) 
   ) 
  ) 
) 
) 
) 
(setvar "OSMODE" OLDOS) 
(setvar "CMDECHO" 1) 
(princ) 
) 
;;;----------次函数getpz:根据四点，求出最佳标注点----------;;; 
(defun getpz (p1 p2 p3 p4 / pp1 pp2 pp3 pp4 ppz1 ppz2 ppz ppp1 ppp2 pp1y pp2y pp3y pp4y) 
(setq  pp1 p1 
  pp2 p2 
  pp3 p3 
  pp4 p4 
  pp1y (atoi (rtos (*(nth 1 pp1) 100) 2 0)) 
  pp2y (atoi (rtos (*(nth 1 pp2) 100) 2 0)) 
  pp3y (atoi (rtos (*(nth 1 pp3) 100) 2 0)) 
  pp4y (atoi (rtos (*(nth 1 pp4) 100) 2 0)) 
) 
;;求最高点 
(if (> pp1y (max pp2y pp3y pp4y)) 
(setq ppz pp1) 
) 
(if (> pp2y (max pp1y pp3y pp4y)) 
(setq ppz pp2) 
) 
(if (> pp3y (max pp2y pp1y pp4y)) 
(setq ppz pp3) 
) 
(if (> pp4y (max pp2y pp3y pp1y)) 
(setq ppz pp4) 
) 
;;若是水平的柱，则求左上角点 
(if (= ppz nil) 
(progn (if (= pp1y (max pp2y pp3y pp4y)) 
   (setq ppp1 pp1) 
   ) 
   (if (= pp2y (max pp1y pp3y pp4y)) 
   (if (= ppp1 nil) (setq ppp1 pp2) (setq ppp2 pp2)) 
   ) 
   (if (= pp3y (max pp2y pp1y pp4y)) 
   (if (= ppp1 nil) (setq ppp1 pp3) (setq ppp2 pp3)) 
   ) 
   (if (= pp4y (max pp2y pp3y pp1y)) 
   (if (= ppp1 nil) (setq ppp1 pp4) (setq ppp2 pp4)) 
   ) 
(setq ppz (if (< (nth 0 ppp1)(nth 0 ppp2)) ppp1 ppp2)) 
) 
) 
(if ppz ppz) 
) 
;;; 函数 bz:dimaligned 用来实现单边的两个标注 ;;; 
(defun bz:dimaligned (p1 p2 p3 p0 / point1 point2 point3 point0 p12 angle32) 
(setq  point1 p1 
  point2 p2 
  point3 p3 
  point0 p0 
  p12 (findper p0 p1 p2) 
  angle32 (angle point3 point2) 
) 
(brbz point1 p12 angle32 point2) 
) 
;;;次函数dxf 
(defun dxf (en dxf) 
(cdr(assoc dxf (entget en))) 
) 
;;;次函数brbz，根据point1 point2 angle32进行避让标注 
(defun brbz(point1 point2 angle32 point3 / e0 p0 e w ed) 
(setq distance12 (distance point1 point2)) 
  (setq distance23 (distance point2 point3)) 
  (cond ((and (equal distance12 distance23 5)(or(equal angle32 0 0.785)(equal angle32 pi 0.1))) 
   (dim point1 point2 angle32 "h1" distance12) 
  (dim point3 point2 angle32 "h2" distance23)) 
  ((and (equal distance12 distance23 5)(> angle32 0.785)) 
   (dim point1 point2 angle32 "b1" distance12) 
  (dim point3 point2 angle32 "b2" distance23)) 
   ((and (< distance12 distance23)(or(equal angle32 0 0.785)(equal angle32 pi 0.1))) 
         (dim point1 point2 angle32 nil distance12) 
         (dim point3 point2 angle32 "h2" distance23) 
   ) 
  ((and (> distance12 distance23)(or(equal angle32 0 0.785)(equal angle32 pi 0.1))) 
   (dim point1 point2 angle32 "h2" distance12) 
  (dim point3 point2 angle32 nil distance23)) 
  ((and (< distance12 distance23)(> angle32 0.785)) 
   (dim point1 point2 angle32 nil distance12) 
   (dim point3 point2 angle32 "b2" distance23)) 
  ((and (> distance12 distance23)(> angle32 0.785)) 
   (dim point1 point2 angle32 "b2" distance12) 
   (dim point3 point2 angle32 nil distance23)) 
  ) 
) ;;end brbz 
(defun dim (point1 point2 angle32 bh distance123 / ) 
  (if (= bh nil) 
    (progn 
  (command "dimlinear" 
   point1 
   point2 
   "t" 
   ;;下面if语句是对标注值进行取整 
   (if (< (ABS(- (* (atoi (rtos (if (> distance123 50) 
          (/ distance123 5) 
         (* distance123 20) 
         ) 
         2 0 
       ) 
     ) 
     5 
     ) 
      
     (if (> distance123 50) 
       distance123 
     (* distance123 100) 
     ) 
   )) 0.5) 
   "<>" 
   (*  (atoi (rtos (if  (> distance123 50) 
       (/ distance123 5) 
       (* distance123 20) 
       ) 
       2 
       0 
     ) 
    ) 
    5 
   ) 
   );end if 
   "r" 
   (* (/ angle32 pi) 180.0) 
   (polar point1 angle32 (if (> distance123 50) 800 8 )) 
));end command 
    (progn 
  (command "dimlinear" 
   point1 
   point2 
   "t" 
   bh 
   "r" 
   (* (/ angle32 pi) 180.0) 
   (polar point1 angle32 (if (> distance123 50) 800 8 )) 
)));end command 
;;获取最近画的标注，判断是否需要避让 
(setq e0 (entlast) 
  p0 (dxf e0 11) 
e (cdr (assoc -2 (tblsearch "block" (dxf e0 2)))) 
) 
(while e 
(if (= (dxf e 0) "MTEXT") 
  (setq w  (dxf e 42) 
   e  nil 
  ) 
  (setq e (entnext e)) 
) 
) 
;;根据条件进行避让 
(if (> w (- distance123 1)) 
(progn 
(setq ed (entget e0); 图元名e0的数据关联表存ed 
ed (subst (cons 11 
       (polar(polar p0 
         (angle point2 point1) 
         (if  (> distance123 50) 350 3.5) 
       ) 
         angle32 (if  (> distance123 50) 100 1) 
       ) 
     ) 
     (assoc 11 ed) 
     ed 
    ); ; ; 更改11 
ed (subst (cons 70 (logior (cdr (assoc 70 ed)) 128))(assoc 70 ed)ed); ; ; 更改70 
) 
(entmod ed) 
) 
) 
  ) 
;;; 函数 findper 根据三点坐标，找某点到其他两点形成线的垂直点 ;;; 
(defun findper(p0 p1 p2 / point0 point1 point2) 
(setq  point0 p0 
  point1 p1 
  point2 p2 
) 
(inters (polar point0 (+(angle point1 point2)(/ pi 2)) 10) point0 point1 point2 nil) 
) 
;;;根据多线段名获得多线段的端点集合 ;;; 
(defun getpline (plname / pts x) 
(setq pts '()) 
(mapcar '(lambda (x) 
   (if (= (car x) 10) 
     (setq pts (cons (cdr x) pts)) 
   ) 
   ) 
   (entget plname) 
) 
(reverse pts) 
) 
;;;-------获得传递来的轴线集合返回轴线端点集合-------------;;; 
(defun gt:ttt (sszx / ss i en lines) 
(if (setq SS sszx) 
(progn 
(setvar "OSMODE" 0) 
(setq i -1) 
(repeat (sslength ss) 
  (setq en (ssname ss (setq i (1+ i)))) 
  (setq lines (append lines (getline en))) 
) 
) 
) 
(if lines lines) 
) 
;;;-------获得传递来的直线端点集合返回直线所有交点集合-----------;;; 
(defun getinter(line / x y lines inter) 
(setq x 0 y 2 
  lines line) 
(setq inter '()) 
(repeat (- (/ (length lines) 2) 1) 
(repeat (- (/ (- (length lines) x) 2) 1) 
(if (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines)) 
(setq inter (cons (inters (nth x lines)(nth (+ x 1) lines)(nth y lines)(nth (+ y 1) lines)) inter)) 
) 
(setq y (+ y 2)) 
) 
(setq x (+ x 2)) 
(setq y (+ x 2)) 
) 
(reverse inter) 
) 
;;;根据直线名获得直线的两个端点集合 ;;; 
(defun getline (lname / pts x ) 
(setq pts '()) 
(mapcar '(lambda (x) 
   (if (or (= (car x) 10) (= (car x) 11)) 
     (setq pts (cons (3dPoint->2dPoint(cdr x)) pts)) 
   ) 
   ) 
   (entget lname) 
) 
(reverse pts) 
) 
;;; 函数：3Dpoint->2Dpoint 
(defun 3dPoint->2dPoint  (3dpt) 
(list (float (car 3dpt)) (float (cadr 3dpt))) 
) 
 
(vl-load-com) 
(setq *acad* (vlax-get-acad-object)) 
(setq *doc* (vla-get-ActiveDocument *acad*)) 
;;带过滤器的entsel 
(defun Fsxm-entsel (msg filter) 
  (setq enp (entsel msg)) 
  (if (or (= (type enp) 'str) 
          (and enp (ssget (cadr enp) filter)) 
      ) 
    enp 
  ) 
) 
;

蓝天利剑3 · 发表于 2013-8-5 00:05:18

真是叼啊！只看懂了一部分啊！

caoliu023 · 发表于 2013-8-14 22:21:00

很有用的资料

米克 · 发表于 2013-8-16 13:45:26

晕要授权码的啊？？？？

ynhh · 发表于 2013-10-29 14:33:12

授权码是什么啊

混沌初开 · 发表于 2013-11-10 23:45:32

楼主这个是干什么用的啊？

qyming1996 · 发表于 2013-12-22 08:04:09

看一看，学习楼主编程

enn09 · 发表于 2014-4-16 15:34:52

感谢分享，支持了

modman · 发表于 2014-6-17 16:14:06

授权码...自己加密？

怒放的生命acai · 发表于 2014-7-4 23:03:35

好东东，新手路过学习...

maxone · 发表于 2014-8-16 11:56:07

其中的炸散嵌套块程序好像对非等比加旋转嵌套块无效

yhly555 · 发表于 2014-9-2 19:19:22

正想学习程序加密

yhly555 · 发表于 2014-9-3 23:11:26

如何再有.dcl对话框源文件就更好了

sicky111 · 发表于 2014-10-15 21:53:47

非常好，感谢楼主分享。

lifei18 · 发表于 2014-10-21 00:23:26

收集不容易啊

账号		自动登录	找回密码
密码			立即注册

[每日一码] 通用收集

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

本帖被以下淘专辑推荐:

相关帖子

点评