xsso 发表于 2013-5-1 23:02 static/image/common/back.gif
呵呵！用通配符来分组，应该是可以的，只是我对wcmatch不熟识，慢慢来
恭候恭候，多谢多谢！
高手解决啊！
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=101166&pid=584081&page=2&extra=#pid584081
加载12楼的fas再执行
(defun c:q2 (/ layers ent lay la1 la2 la3 for)
(defun for (layer`s / val)
(FOREACH val layer`s
(if (= (type val) 'list)
(for val)
(if (= val lay)
;;(wcmatch lay val)
(lay_iso_* layer`s)
) ;_ 结束if
) ;_ 结束FOREACH
) ;_ 结束FOREACH
) ;_ 结束defun
(setq la1 (lay_wcmatch "E*")
la2 (lay_wcmatch "D*")
la3 (lay_wcmatch "P*")
layers (list la1 la2 la3)
ent (entget (car (entsel "\n选择物")))
lay (cdr (assoc 8 ent))
) ;_ 结束setq
(for layers)
) ;_ 结束defun
经此一役开始学习wcmatch函数
本帖最后由 夏生生 于 2013-5-3 00:57 编辑
写的还是不够好，缺点是命名图层组的时候要用单字符，最好是1~9和非A英文字母，楼主的要求是基本达到了，请大家指正，个人认为用对话框模式写这种程序是最好的，但是本人的DCL太烂，待高人完善。谢谢。
(vl-load-com)
(defun x_ssn (ss / n lst)
(repeat (setq N (sslength ss))
(setq LST (cons (ssname SS (setq N (1- N))) LST))
)
)
(defun del_lst_eq (lst)
(if lst
(cons (car lst)
(del_lst_eq (vl-remove (car lst) (cdr lst)))
)
)
)
(defun str-strlst (str br / n lst)
(while (setq n (vl-string-search br str))
(setq lst (cons (substr str 1 n) lst))
(setq str (substr str (+ 2 n)))
)
(reverse lst)
)
(defun off_lay (layernamelst / x ent)
(mapcar '(lambda (x)
(setq ent (entget (tblobjname "layer" x))
ent (subst (cons 62 (- (cdr (assoc 62 ent))))
(assoc 62 ent)
ent
)
)
(entmod ent)
)
layernamelst
)
)
;;;选择关层
(defun c:x_lon (/ ss tcz_lst OI zn en x oldtcz lst lay)
(setqtcz_lst(vl-remove-if-not
'(lambda (x) (wcmatch x "`*`*图层组*`*`*"))
(atoms-family 1)
)
)
;;;(mapcar 'eval(mapcar'read tcz_lst))
(initget "Make Delete Join Off")
(setq
OI (getkword "\n图层组操作[新建(M)/删除(D)/增补(J)/关闭(O)]<O>"
)
)
(cond
((= OI "Make")
(setq zm (getstring "\n输入需定义的图层组名："))
(while (eval (read (strcat "**图层组" zm "**")))
;(member (strcat "**图层组" zm "**") tcz_lst)
(princ "\n图层组名已定义，重定义。")
(setq zm (getstring "\n输入需定义的图层组名："))
)
(prompt "\n选择特征图元")
(setq ss (ssget))
(set (read (strcat "**图层组" zm "**"))
(apply
'strcat
(mapcar '(lambda (en) (strcat en ","))
(del_lst_eq
(mapcar '(lambda (en) (cdr (assoc 8 (entget en))))
(x_ssn ss)
)
)
)
)
)
(textpage)
(princ (strcat "新建图层组"
zm
"\n包含图层："
(eval (read (strcat "**图层组" zm "**")))
)
)
)
((= OI "Delete")
(setq zm (getstring "\n输入图层组名或 [?]"))
(while (or(= zm "?")
(null (eval (read (strcat "**图层组" zm "**"))))
)
(if (= zm "?")
(progn
(mapcar '(lambda (x)
(setq x (substr x 9))
(princ (strcat "\n" (substr x 1 (- (strlen x) 2))))
)
tcz_lst
)
(textpage)
(setq zm (getstring "\n输入图层组名或 [?]"))
)
(progn(princ "\n图层组名不存在")
(setq zm (getstring "\n输入图层组名或 [?]"))
)
)
)
(set (read (strcat "**图层组" zm "**")) nil)
)
((= OI "Join")
(setq zm (getstring "\n输入图层组名或 [?]"))
(while (or(= zm "?")
(null (eval (read (strcat "**图层组" zm "**"))))
)
(if (= zm "?")
(progn
(mapcar '(lambda (x)
(setq x (substr x 9))
(princ (strcat "\n" (substr x 1 (- (strlen x) 2))))
)
tcz_lst
)
(textpage)
(setq zm (getstring "\n输入图层组名或 [?]"))
)
(progn(princ "\n图层组名不存在")
(setq zm (getstring "\n输入图层组名或 [?]"))
)
)
)
(setq oldtcz (eval (read (strcat "**图层组" zm "**"))))
(prompt "\n选择增加的特征图元：")
(setq ss (ssget))
(set
(read (strcat "**图层组" zm "**"))
(apply
'strcat
(mapcar
'(lambda (en) (strcat en ","))
(del_lst_eq
(append
(mapcar '(lambda (en) (cdr (assoc 8 (entget en))))
(x_ssn ss)
)
(str-strlst oldtcz ",")
)
)
)
)
)
(princ (strcat "\n图层组"
zm
"包含图层由："
oldtcz
"\n变为:"
(eval (read (strcat "**图层组" zm "**")))
)
)
)
((= OI "Off")
(setq en
(cdr
(assoc 8 (entget (car (entsel "\n选择图层组中特征图元："))))
)
)
;;; (setq lst(mapcar '(lambda(x)(cons x (str-strlst(eval(read x))",")))tcz_lst))
(setq lst
(vl-remove-if-not
'(lambda (x) (member en (str-strlst (eval (read x)) ",")))
tcz_lst
)
)
(if (> (length lst) 1)
(progn
(initget
(strcat
(apply 'strcat
(mapcar '(lambda (x)
(setq x (substr x 9))
(strcat (substr x 1 (- (strlen x) 2)) " ")
)
lst
)
)
"ALL"
)
)
(setq OI
(getkword
(strcat
"\n图元属多个组["
(apply 'strcat
(mapcar '(lambda (x)
(setq x (substr x 3))
(setq x (substr x 1 (- (strlen x) 2)))
(strcat x "(" (substr x 7) ")/")
)
lst
)
)
"全部所属(A)]<A>"
)
)
)
(cond
((= OI "ALL")
(setq
lay (del_lst_eq
(apply
'append
(mapcar
'(lambda (x) (str-strlst (eval (read x)) ","))
lst
)
)
)
)
(off_lay lay)
)
((/= OI "ALL")
(setq lay(vl-remove-if-not'(lambda(x)(wcmatch x (strcat "**图层组"oi"**")))tcz_lst))
(off_lay (str-strlst (eval (read (car lay))) ","))
)
)
)
(off_lay (str-strlst (eval (read (car lst))) ","))
)
)
)
(princ)
)
xsso 发表于 2013-5-2 22:45 static/image/common/back.gif
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=101166&pid=584081&page=2&extra=#pid584081
加载12楼 ...
程序效果很好，当前层问题也解决了，只是各分组只能添加单一前缀的图层？比如在分组一里面，我希望是可以添加如下图层：E*，EE，EC，EC*……，这样一来分组就更人性化了，已经接近最理想的 答案了，有劳朋友继续！
试试这个
效果很好，但不够直观，要能像图层管理器那样直观就好了，例如添加JZ 就可以对所有的JZ*图层操作 你看一下帮助说明。
本帖最后由 xsso 于 2013-5-3 22:10 编辑
fire9527 发表于 2013-5-3 07:04 static/image/common/back.gif
程序效果很好，当前层问题也解决了，只是各分组只能添加单一前缀的图层？比如在分组一里面，我希望是可以 ...
这是原来的分组(setq la1 (lay_wcmatch "E*")
la2 (lay_wcmatch "D*")
la3 (lay_wcmatch "P*")
layers (list la1 la2 la3)
ent (entget (car (entsel "\n选择物")))
lay (cdr (assoc 8 ent))
) ;_ 结束setq但其实可以这样分组的(setq la1 (lay_wcmatch "E*,F*,A,B")
la2 (lay_wcmatch "D*")
la3 (lay_wcmatch "P*")
layers (list (append '("abc") la1 la2 ) la3);_ 这里决定如何分组
ent (entget (car (entsel "\n选择物")))
lay (cdr (assoc 8 ent))
) ;_ 结束setq在我所知，它的分组条件已经很无限
夏生生 发表于 2013-5-3 00:54 static/image/common/back.gif
写的还是不够好，缺点是命名图层组的时候要用单字符，最好是1~9和非A英文字母，楼主的要求是基本达到了，请 ...
高手！参考一下有什么可以学习