有关联图层控制程序吗？

fire9527 · 发表于 2013-5-1 23:38:28

xsso 发表于 2013-5-1 23:02
呵呵！用通配符来分组，应该是可以的，只是我对wcmatch不熟识，慢慢来

恭候恭候，多谢多谢！

cuyongping · 发表于 2013-5-2 20:00:16

高手解决啊！

xsso · 发表于 2013-5-2 22:45:59

http://bbs.mjtd.com/forum.php?mo ... mp;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

xsso · 发表于 2013-5-2 22:49:06

经此一役开始学习wcmatch函数

夏生生 · 发表于 2013-5-3 00:54:35

本帖最后由夏生生于 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)
(setq tcz_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)
)

(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) 
  (setq  tcz_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) 
)

fire9527 · 发表于 2013-5-3 07:04:48

xsso 发表于 2013-5-2 22:45
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=101166&pid=584081&page=2&extra=#pid584081
加载12楼 ...

程序效果很好，当前层问题也解决了，只是各分组只能添加单一前缀的图层？比如在分组一里面，我希望是可以添加如下图层：E*，EE，EC，EC*……，这样一来分组就更人性化了，已经接近最理想的答案了，有劳朋友继续！

smartstar · 发表于 2013-5-3 09:04:11

试试这个

smartstar · 发表于 2013-5-3 10:11:29

效果很好，但不够直观，要能像图层管理器那样直观就好了，例如添加JZ 就可以对所有的JZ*图层操作

你看一下帮助说明。

xsso · 发表于 2013-5-3 22:09:25

本帖最后由 xsso 于 2013-5-3 22:10 编辑

fire9527 发表于 2013-5-3 07:04
程序效果很好，当前层问题也解决了，只是各分组只能添加单一前缀的图层？比如在分组一里面，我希望是可以 ...

这是原来的分组

(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[1-3],B[a-z]")
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

在我所知，它的分组条件已经很无限

xsso · 发表于 2013-5-3 22:44:40

夏生生发表于 2013-5-3 00:54
写的还是不够好，缺点是命名图层组的时候要用单字符，最好是1~9和非A英文字母，楼主的要求是基本达到了，请 ...

高手！

参考一下有什么可以学习

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

有关联图层控制程序吗？

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评