 - ;;声明 本代码均来自 llsheng_73 本人只做局部修改调试,烦请73兄见谅.
- ;;73兄的代码基本上很完整了,DCL有很好的优势,以下是根据个人习惯做了些修改.
- ;;如果楼主觉得可以用，烦请将悬赏币给予 llsheng_73 兄.
- ;;增加手工填写默认图层(图纸规范适用)
- ;;增加选择对象图层顺序(按选择先后排序)
- ;;增加载入当前所有图层
- ;;增加快捷键(提高效率,比如运行命令后出现的是dcl界面,那么按s可以直接切换到选择图层模式.)
- ;;增加选择提示语句
- ;;修改上下移动没有选择的情况下出现错误的bug
- ;;修改执行命令时候没有选择出错的bug
- ;;修改主程序为函数,方便改命令,(这个有点多余,可以忽略).
- ;;modify by edata 2015-8-30
- (DEFUN break_ds(/ lys d c d e ss)
- (if(and (setq d(setlys) lys(cdr d))
- (princ (strcat "\n选择打断对象{"(apply'strcat(mapcar'(lambda(x)(strcat"->"x))lys))"}:"))
- (setq ss (ssget(list'(0 . "line,arc,lwpolyline")(cons 8(apply'strcat(mapcar'(lambda(x)(strcat","x))lys)))))))
- (progn
- (setvar'cmdecho 0)
- (command"undo""be")
- (setq d(cons 40(/(car d)2.)))
- (princ "\n正在处理...")
- (foreach a(intersof ss lys)
- (foreach b(setq c(car a)a(vl-sort(cdr a)'(lambda(x y)(>(vlax-curve-getDistAtPoint c x)(vlax-curve-getDistAtPoint c y)))))
- (command"trim"(setq e(entmakex(list'(0 . "circle")(cons 10 b)d)))""(list c b)"")
- (entdel e)))
- (princ "\r处理完成...")
- (command"undo""end")
- (setvar'cmdecho 1)))
- (princ)
- )
- (defun makedcl (str_lst / dclfile fileID dclHandle)
- (setq dclfile(vl-filename-mktemp nil nil ".dcl")fileID(open dclfile "w"))
- (cond((= (type str_lst) 'str)(write-line str_lst fileID))
- ((= (type str_lst) 'list)(foreach n str_lst (write-line n fileID))))
- (close fileID)
- (setq dclHandle (load_dialog dclfile))
- (vl-file-delete dclfile)
- dclHandle)
- (defun setlys(/ lys dcl setlys_move setlys_dl setlys_rd lays a l);;;by llsheng_73
- (Defun lays(/ snl sll)
- (SetQ sll (TblNext "layer" T))
- (While (SetQ snl (Cons (Cdr (Assoc 2 sll)) snl)sll (TblNext "layer" nil)))
- (vl-sort snl '<))
- (defun setlys_move(f);;;by llsheng_73
- (if(setq a(read(strcat "("(get_tile"LYS")")")))
- (progn(setq l(mapcar'(lambda(x)(nth x lys))a)
- lys(if f(append(setq a(append(reverse(cddr(member(car l)(reverse lys))))l))(vl-remove-if'(lambda(x)(member x a))lys))
- (append(setq a(append(vl-remove-if'(lambda(x)(member x l))(reverse(member(last l)(reverse lys))))
- (vl-remove'nil(cons(cadr(member(last l)lys))l))))(vl-remove-if'(lambda(x)(member x a))lys))))
- (start_list"LYS")(mapcar'add_list lys)(end_list)
- (set_tile"LYS"(setq a(mapcar'(lambda(x)(itoa(vl-position x lys)))l)
- a(strcat(car a)(apply'strcat(mapcar'(lambda(x)(strcat" "x))(cdr a)))))))))
- (defun setlys_dl()
- (start_list"LYS")(mapcar'add_list(setq a(read(strcat "("(get_tile"LYS")")"))
- l(mapcar'(lambda(x)(nth x lys))a)
- lys(vl-remove-if'(lambda(x)(member x l))lys)))(end_list))
- (defun setlys_rd()
- (setq d(vlax-ldata-get"myset""layers")
- lys(if d(cdr d)(lays))d(if d(car d)200))
- (set_tile"IN"(rtos d))
- (start_list"LYS")(mapcar'add_list LYS)(end_list))
- (defun load_all()
- (setq lys (lays))
- (start_list"LYS")(mapcar'add_list LYS)(end_list)
- )
- (defun load_default(/ default_lays)
- (setq default_lays '("图层1" "图层2" "图层3" "图层4" "图层5" "图层6" "图层7" "图层8" "图层9"))
- (setq lys default_lays)
- (start_list"LYS")(mapcar'add_list lys)(end_list)
- )
- (setq dcl(makedcl'("SETLYS:dialog{label=\"设置图层顺序\";:edit_box{key=\"IN\";label=\"修剪距离(&J)\";}"
- ":row{:list_box{key=\"LYS\";multiple_select=true;}"
- ":column{:button{key=\"newset\";label=\"选择图层(&S)\";}:button{key=\"default\";label=\"默认图层(&M)\";}
- :button{key=\"load_all\";label=\"载入所有(&A)\";}:button{key=\"UP\";label=\"上移(&U)\";}:button{key=\"DN\";label=\"下移(&D)\";}"
- ":button{key=\"DL\";label=\"移除(&E)\";}:button{key=\"RD\";label=\"重置(&R)\";} "
- "spacer;:button{key=\"GO\";label=\"确定(&O)\";is_default=true;}"
- ":button{key=\"ESC\";label=\"取消(&C)\";is_cancel=true;}}}}")))
- (new_dialog"SETLYS"dcl)
- (setlys_rd)
- (action_tile"default""(load_default)")
- (action_tile"load_all""(load_all)")
- (action_tile"newset""(done_dialog 2)")
- (action_tile"UP""(setlys_move t)")
- (action_tile"DN""(setlys_move nil)")
- (action_tile"DL""(setlys_dl)")
- (action_tile"RD""(setlys_rd)")
- (action_tile"IN""(if(or(not(setq d(distof $value)))(<= d 0))(progn(alert\"修剪距离应该大于0\")(mode_tile\"IN\"2)))")
- (action_tile"GO""(done_dialog 1)")
- (setq _re(start_dialog))
- (cond
- ((= _re 2)(new_select))
- ((= _re 1)(if (and d lys) (vlax-ldata-put"myset""layers"(cons d lys)))
- (vlax-ldata-get "myset" "layers")
- ))
- )
- (defun subtotal(lst m ns / myfun a b c);;;by llslheng_73
- (defun myfun(x)(list(nth ns x)))
- (foreach x lst
- (setq a(if(setq c(nth m x)b(assoc c a))
- (subst(append b(myfun x))b a)
- (append a(list(append(list c)(myfun x))))))))
- (defun intersof(ss lys / a b c d e i pts);;;by llslheng_73
- (setq i 0)
- (repeat(1-(sslength ss))
- (repeat(sslength(setq i -1 a(ssname ss 0)d(cdr(assoc 8(entget a)))ss(ssdel a ss)))
- (if(and(setq i(1+ i) b(ssname ss i) e(cdr(assoc 8(entget b)))
- c(if(/= e d)(apply'vla-IntersectWith(append(mapcar'vlax-ename->vla-object(list a b))'(0)))))
- (>(vlax-safearray-get-u-bound(setq c(vlax-variant-value c))1) 0))
- (setq pts(cons(list(vlax-safearray->list c)
- (caar(vl-sort(list(list a d)(list b e))'(lambda(x y)(>(vl-position(last x)lys)(vl-position(last y)lys))))))pts)))))
- (subtotal pts 1 0))
- (defun new_select(/ ss ss_lst lys d x)
- (princ"\n按顺序选择对象获取图层:")
- (if(setq ss(ssget '((0 . "line,arc,lwpolyline"))))
- (progn
- (setq ss_lst(vl-remove-if-not '(lambda(X)(= (type X) 'ENAME)) (mapcar 'cadr (ssnamex SS))))
- (setq ss_lst(mapcar 'vlax-ename->vla-object ss_lst))
- (setq lys(mapcar 'vla-get-layer ss_lst))
- (setq d(vlax-ldata-get"myset""layers")
- d(if d(car d)200))
- (if lys
- (progn
- (setq lys (delsame lys))
- (vlax-ldata-put"myset""layers" (cons d lys))
- )
- )
- (setlys)
- )
- )
- )
- (defun delsame(l1 / l2);;表中去除重复元素(重复过的取第一次出现) ;;;by llslheng_73
- (while(setq l2(cons(car l1)l2)l1(vl-remove(car l1)(cdr l1))))
- (reverse l2))
- (defun c:tt ()
- (break_ds))
- (alert"依图层交点修剪，命令TT\n更多需求QQ275988734")
| 
楼主
显身卡
发表于 2015-8-30 12:23
发表于 2015-8-30 19:47