急求按顺序打断线条的程序！！！

theisland

llsheng_73 发表于 2015-8-30 09:12
今天要出去，晚上回来再加上可以在图形中选择一些图层，另外增加一个反选。。。
另外列表是可以多选并 ...

反选~~本来我需要的图层很多，反选就要选半天，现在的情况是图中需要打断的图层几十个，其他图层更是数不胜数，所以我觉得设置默认图层是很有必要的，对于其他项目也能很快的应用啊，增加反选是好事，但确实是很需要有默认图层顺序，谢谢大神深夜相助

theisland

vectra 发表于 2015-8-30 09:46
增加了交互部分

哈哈，差不多就这个效果，不过还有点小问题：对于虚线线型，貌似打断有问题

edata

1. ;;声明 本代码均来自 llsheng_73  本人只做局部修改调试,烦请73兄见谅.
   
2. ;;73兄的代码基本上很完整了,DCL有很好的优势,以下是根据个人习惯做了些修改.
   
3. ;;如果楼主觉得可以用，烦请将悬赏币给予 llsheng_73 兄.
   
4. ;;增加手工填写默认图层(图纸规范适用)
   
5. ;;增加选择对象图层顺序(按选择先后排序)
   
6. ;;增加载入当前所有图层
   
7. ;;增加快捷键(提高效率,比如运行命令后出现的是dcl界面,那么按s可以直接切换到选择图层模式.)
   
8. ;;增加选择提示语句
   
9. ;;修改上下移动没有选择的情况下出现错误的bug
   
10. ;;修改执行命令时候没有选择出错的bug
    
11. ;;修改主程序为函数,方便改命令,(这个有点多余,可以忽略).
    
12. ;;modify by edata 2015-8-30
    
13. (DEFUN break_ds(/ lys d c d e ss)
    
14.   (if(and (setq d(setlys) lys(cdr d))
    
15.           (princ (strcat "\n选择打断对象{"(apply'strcat(mapcar'(lambda(x)(strcat"->"x))lys))"}:"))
    
16.           (setq ss (ssget(list'(0 . "line,arc,lwpolyline")(cons 8(apply'strcat(mapcar'(lambda(x)(strcat","x))lys)))))))
    
17.     (progn
    
18.       (setvar'cmdecho 0)
    
19.       (command"undo""be")      
    
20.       (setq d(cons 40(/(car d)2.)))
    
21.       (princ "\n正在处理...")
    
22.       (foreach a(intersof ss lys)
    
23.         (foreach b(setq c(car a)a(vl-sort(cdr a)'(lambda(x y)(>(vlax-curve-getDistAtPoint c x)(vlax-curve-getDistAtPoint c y)))))
    
24.           (command"trim"(setq e(entmakex(list'(0 . "circle")(cons 10 b)d)))""(list c b)"")
    
25.           (entdel e)))
    
26.       (princ "\r处理完成...")
    
27.       (command"undo""end")
    
28.       (setvar'cmdecho 1)))
    
29.   (princ)
    
30.   )
    
31. (defun makedcl (str_lst / dclfile fileID dclHandle)
    
32.   (setq  dclfile(vl-filename-mktemp nil nil ".dcl")fileID(open dclfile "w"))
    
33.   (cond((= (type str_lst) 'str)(write-line str_lst fileID))
    
34.        ((= (type str_lst) 'list)(foreach n str_lst (write-line n fileID))))
    
35.   (close fileID)
    
36.   (setq dclHandle (load_dialog dclfile))
    
37.   (vl-file-delete dclfile)
    
38.   dclHandle)
    
39. (defun setlys(/ lys dcl setlys_move setlys_dl setlys_rd lays a l);;;by llsheng_73
    
40.   (Defun lays(/ snl sll)
    
41.   (SetQ sll (TblNext "layer" T))
    
42.   (While (SetQ snl (Cons (Cdr (Assoc 2 sll)) snl)sll (TblNext "layer" nil)))
    
43.   (vl-sort snl '<))
    
44.   (defun setlys_move(f);;;by llsheng_73
    
45.     (if(setq a(read(strcat "("(get_tile"LYS")")")))
    
46.       (progn(setq l(mapcar'(lambda(x)(nth x lys))a)          
    
47.           lys(if f(append(setq a(append(reverse(cddr(member(car l)(reverse lys))))l))(vl-remove-if'(lambda(x)(member x a))lys))
    
48.                (append(setq a(append(vl-remove-if'(lambda(x)(member x l))(reverse(member(last l)(reverse lys))))
    
49.                                     (vl-remove'nil(cons(cadr(member(last l)lys))l))))(vl-remove-if'(lambda(x)(member x a))lys))))
    
50.     (start_list"LYS")(mapcar'add_list lys)(end_list)
    
51.     (set_tile"LYS"(setq a(mapcar'(lambda(x)(itoa(vl-position x lys)))l)
    
52.                         a(strcat(car a)(apply'strcat(mapcar'(lambda(x)(strcat" "x))(cdr a)))))))))
    
53.   (defun setlys_dl()
    
54.     (start_list"LYS")(mapcar'add_list(setq a(read(strcat "("(get_tile"LYS")")"))
    
55.                                            l(mapcar'(lambda(x)(nth x lys))a)
    
56.                                            lys(vl-remove-if'(lambda(x)(member x l))lys)))(end_list))
    
57.   (defun setlys_rd()
    
58.     (setq d(vlax-ldata-get"myset""layers")
    
59.           lys(if d(cdr d)(lays))d(if d(car d)200))
    
60.     (set_tile"IN"(rtos d))
    
61.     (start_list"LYS")(mapcar'add_list LYS)(end_list))
    
62.   (defun load_all()
    
63.     (setq lys (lays))
    
64.     (start_list"LYS")(mapcar'add_list LYS)(end_list)
    
65.     )
    
66.   (defun load_default(/ default_lays)
    
67.     (setq default_lays '("图层1" "图层2" "图层3" "图层4" "图层5" "图层6" "图层7" "图层8" "图层9"))
    
68.     (setq lys default_lays)
    
69.     (start_list"LYS")(mapcar'add_list lys)(end_list)
    
70.     )
    
71.   (setq dcl(makedcl'("SETLYS:dialog{label=\"设置图层顺序\";:edit_box{key=\"IN\";label=\"修剪距离(&J)\";}"
    
72.                      ":row{:list_box{key=\"LYS\";multiple_select=true;}"
    
73.                      ":column{:button{key=\"newset\";label=\"选择图层(&S)\";}:button{key=\"default\";label=\"默认图层(&M)\";}
    
74.                      :button{key=\"load_all\";label=\"载入所有(&A)\";}:button{key=\"UP\";label=\"上移(&U)\";}:button{key=\"DN\";label=\"下移(&D)\";}"
    
75.                      ":button{key=\"DL\";label=\"移除(&E)\";}:button{key=\"RD\";label=\"重置(&R)\";} "
    
76.                      "spacer;:button{key=\"GO\";label=\"确定(&O)\";is_default=true;}"
    
77.                      ":button{key=\"ESC\";label=\"取消(&C)\";is_cancel=true;}}}}")))
    
78.   (new_dialog"SETLYS"dcl)
    
79.   (setlys_rd)
    
80.   (action_tile"default""(load_default)")
    
81.   (action_tile"load_all""(load_all)")
    
82.   (action_tile"newset""(done_dialog 2)")
    
83.   (action_tile"UP""(setlys_move t)")
    
84.   (action_tile"DN""(setlys_move nil)")
    
85.   (action_tile"DL""(setlys_dl)")
    
86.   (action_tile"RD""(setlys_rd)")
    
87.   (action_tile"IN""(if(or(not(setq d(distof $value)))(<= d 0))(progn(alert\"修剪距离应该大于0\")(mode_tile\"IN\"2)))")
    
88.   (action_tile"GO""(done_dialog 1)")
    
89.   (setq _re(start_dialog))
    
90.   (cond
    
91.     ((= _re 2)(new_select))
    
92.     ((= _re 1)(if (and d lys) (vlax-ldata-put"myset""layers"(cons d lys)))
    
93.      (vlax-ldata-get "myset" "layers")
    
94.                          ))
    
95.     )
    
96. (defun subtotal(lst m ns / myfun a b c);;;by llslheng_73
    
97.   (defun myfun(x)(list(nth ns x)))
    
98.   (foreach x lst
    
99.     (setq a(if(setq c(nth m x)b(assoc c a))
    
100.              (subst(append b(myfun x))b a)
     
101.              (append a(list(append(list c)(myfun x))))))))
     
102. (defun intersof(ss lys / a b c d e i pts);;;by llslheng_73
     
103.   (setq i 0)
     
104.   (repeat(1-(sslength ss))
     
105.     (repeat(sslength(setq i -1 a(ssname ss 0)d(cdr(assoc 8(entget a)))ss(ssdel a ss)))
     
106.       (if(and(setq i(1+ i) b(ssname ss i) e(cdr(assoc 8(entget b)))
     
107.                    c(if(/= e d)(apply'vla-IntersectWith(append(mapcar'vlax-ename->vla-object(list a b))'(0)))))
     
108.              (>(vlax-safearray-get-u-bound(setq c(vlax-variant-value c))1) 0))
     
109.         (setq pts(cons(list(vlax-safearray->list c)
     
110.                            (caar(vl-sort(list(list a d)(list b e))'(lambda(x y)(>(vl-position(last x)lys)(vl-position(last y)lys))))))pts)))))
     
111.   (subtotal pts 1 0))
     
112. (defun new_select(/ ss ss_lst lys d x)
     
113.   (princ"\n按顺序选择对象获取图层:")
     
114.   (if(setq ss(ssget '((0 . "line,arc,lwpolyline"))))
     
115.     (progn
     
116.       (setq ss_lst(vl-remove-if-not '(lambda(X)(= (type X) 'ENAME)) (mapcar 'cadr (ssnamex SS))))
     
117.       (setq ss_lst(mapcar 'vlax-ename->vla-object ss_lst))
     
118.       (setq lys(mapcar 'vla-get-layer ss_lst))
     
119.       (setq d(vlax-ldata-get"myset""layers")
     
120.             d(if d(car d)200))
     
121.       (if lys
     
122.         (progn
     
123.           (setq lys (delsame lys))          
     
124.           (vlax-ldata-put"myset""layers" (cons d lys))
     
125.           )
     
126.         )      
     
127.       (setlys)
     
128.       )
     
129.     )  
     
130.   )
     
131. (defun delsame(l1 / l2);;表中去除重复元素(重复过的取第一次出现) ;;;by llslheng_73
     
132.   (while(setq l2(cons(car l1)l2)l1(vl-remove(car l1)(cdr l1))))
     
133.   (reverse l2))
     
134. (defun c:tt ()  
     
135.   (break_ds))
     
136. (alert"依图层交点修剪，命令TT\n更多需求QQ275988734")

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

theisland

edata 发表于 2015-8-30 12:23

如获至宝，e大的整合独具匠心，又帮了我一个大忙！同时非常感激 lisheng_73、Vectra、etoxp这几位朋友的鼎力相助，叩谢各位大神，可惜最佳答案只能设置一个~~！程序已经超乎想象的完美了，开心开心

xyp1964

chenbh2

edata 发表于 2015-8-30 12:23

能不能帮我做个个这样的效果！

jltx123456

楼主这样下去，就是第二个flytoday , 大家都懂的，100个币也就10块钱，充1000个币 ，一套定制的工具箱就到手了，
http://bbs.mjtd.com/thread-109714-1-1.html

xyp1964

;; 图层可控

llsheng_73

theisland 发表于 2015-8-30 11:04
反选~~本来我需要的图层很多，反选就要选半天，现在的情况是图中需要打断的图层几十个，其他图层更是数不 ...

其实别的东东最多花了半小时左右，那个对话框搞了好几个小时，主要卡在多选时的上移下移了，其实也是对自己的一个挑战，并且最终成功了

edata

llsheng_73 发表于 2015-8-30 22:54
其实别的东东最多花了半小时左右，那个对话框搞了好几个小时，主要卡在多选时的上移下移了，其实也是对自 ...

多选move是很了不起的函数，UP\DN通过一个函数来控制，节约了代码，提高了效率，至于求交点算法上每个人有每个人的写法，我的思路略有差异，空了完善了对比对比。
。
ps：jltx123456质疑这个事，确实很难说，网络毕竟虚拟，但是我个人觉得，只要自己觉得有时间，讨论一些个有意义的函数，代码，解决方式还是可以的，而不是为了什么悬赏，一切只因为兴趣，通过这个程序，实现了简化操作，提高工作效率，并且可以了解不同人的编写思路，运用函数的方法，让自己更深入的了解lisp，运用lisp，我相信目前73兄也有这种心态，人帮人，人人帮人，只有这样，才能够让lisp继续下去，更多人了解并运用lisp解决各种行业问题。
其实我也不知道flytoday的事是真是假，也没什么兴趣知道，我记得以前还有个KO什么的，可能在论坛中也存在一些人，就是为了代码，而我相信更多的人是为了学习，比如说434939575，BenjaminXM，等等，他们也一直在学习，交流。
lisp只要你花时间，肯定能学会，像73兄弄到很晚，几乎占用了全部业余时间，还到凌晨，能不学好lisp吗，想当初，我也差不多是这种状态，为了解决某个问题，一空下来就想怎么处理这个问题，采用什么样的方式，不停的推演，除了工作，吃饭，这就是唯一能想的事，你能达到这个要求，什么事都能做好，不止是对于lisp，也是包括你的工作，感情，你报以100%的激情，你肯定能干出一番事业。。。