帮忙修改下程序，选物单开图层并将此物图层置为当前

cj52000

各位大佬，以下程序为选物单开图层，但是选中物体的图层不能置为当前，请帮忙修改下将选中物体的图层置为当前，谢谢！

(defun c:1 (/ n1 n2 n3 n4 n5 n ent)

(setvar "cmdecho" 0)
(setq n1 (ssget))
(setq n2 (sslength n1))
(command "layer" "off" "*" "y" "")
(setq n 0)
(while (> n2 n)
     (setq ent (ssname n1 n))
     (setq n3 (assoc 8 (setq n4 (entget ent))))
     (setq n5 (cdr n3))
     (command "layer" "on" n5 "")
     (setq n (+ 1 n))))

kucha007

试试这个

1. ;关闭其它图层并将目标图层置为当前
   
2. 
   
3. (defun c:TT (/ DOC LayLst SS i obj Lay LayOpen en TgtLay)
   
4.   (if (null vlax-dump-object) (vl-load-com));;将Visual LISP扩展功能加载到AutoLISP
   
5.   (setq DOC    (vla-get-activedocument (vlax-get-acad-object))
   
6.         LayLst (vla-get-layers DOC)
   
7.   )
   
8.   (defun *error* (Msg)
   
9.     (vla-endundomark DOC)
   
10.   )
    
11.   (while (eq 8 (logand 8 (getvar 'undoctl)))
    
12.     (vla-endundomark DOC)
    
13.   ) ;关闭以前的编组
    
14.   (vla-startundomark DOC) ;记录编组
    
15.     (if
    
16.       (and
    
17.           (princ "\n——★★★ 请选择需要保留图层的对象 ★★★——\n")
    
18.           (setq SS (ssget))
    
19.       )
    
20.       (progn
    
21.         (vlax-for XX LayLst (vla-put-layeron XX :vlax-false)) ;图层全关
    
22.         (repeat (setq i (sslength SS))
    
23.           (setq obj (vlax-ename->vla-object (ssname SS (setq i (1- i))))
    
24.                 Lay (vla-get-Layer obj)
    
25.           )
    
26.           (if (not (vl-position Lay LayOpen))
    
27.             (progn
    
28.               (vla-put-layeron (vla-item LayLst Lay) :vlax-true) ;打开目标图层
    
29.               (setq LayOpen (cons Lay LayOpen))
    
30.             )
    
31.           )
    
32.         );关闭其它
    
33.         (princ "\n——★★★ 已关闭除所选对象以外的其它图层 ★★★——\n")
    
34.         (if (setq en (car (entsel "\n→请点选目标图层的对象：")))
    
35.             (progn
    
36.               (setq TgtLay (Vlax-Get (Vlax-Ename->Vla-Object en) 'Layer)) ;获取目标图层
    
37.               (setvar "CLAYER" TgtLay) ;图层置为当前
    
38.                (princ (strcat "\n——★★★ 目标图层<" TgtLay ">已置为当前 ★★★——\n"))
    
39.             )
    
40.         )
    
41.       )
    
42.     )
    
43.   (vla-endundomark DOC) ;结束编组
    
44.   (command "redraw")
    
45.   (princ)
    
46. )
    

;关闭其它图层并将目标图层置为当前<br /> <br /> (defun c:TT (/ DOC LayLst SS i obj Lay LayOpen en TgtLay) <br />   (if (null vlax-dump-object) (vl-load-com));;将Visual LISP扩展功能加载到AutoLISP<br />   (setq DOC    (vla-get-activedocument (vlax-get-acad-object))<br />         LayLst (vla-get-layers DOC)<br />   )<br />   (defun *error* (Msg)<br />     (vla-endundomark DOC)<br />   )<br />   (while (eq 8 (logand 8 (getvar 'undoctl))) <br />     (vla-endundomark DOC)<br />   ) ;关闭以前的编组<br />   (vla-startundomark DOC) ;记录编组<br />     (if <br />       (and<br />           (princ "\n——★★★ 请选择需要保留图层的对象 ★★★——\n")<br />           (setq SS (ssget))<br />       ) <br />       (progn<br />         (vlax-for XX LayLst (vla-put-layeron XX :vlax-false)) ;图层全关<br />         (repeat (setq i (sslength SS))<br />           (setq obj (vlax-ename->vla-object (ssname SS (setq i (1- i))))<br />                 Lay (vla-get-Layer obj)<br />           )<br />           (if (not (vl-position Lay LayOpen))<br />             (progn<br />               (vla-put-layeron (vla-item LayLst Lay) :vlax-true) ;打开目标图层<br />               (setq LayOpen (cons Lay LayOpen))<br />             )<br />           )<br />         );关闭其它<br />         (princ "\n——★★★ 已关闭除所选对象以外的其它图层 ★★★——\n")<br />         (if (setq en (car (entsel "\n→请点选目标图层的对象："))) <br />             (progn <br />               (setq TgtLay (Vlax-Get (Vlax-Ename->Vla-Object en) 'Layer)) ;获取目标图层<br />               (setvar "CLAYER" TgtLay) ;图层置为当前<br />                (princ (strcat "\n——★★★ 目标图层<" TgtLay ">已置为当前 ★★★——\n"))<br />             )<br />         )<br />       )<br />     )<br />   (vla-endundomark DOC) ;结束编组<br />   (command "redraw")<br />   (princ)<br /> )<br />

zhufeng1004

试试这个

(Defun C:y (/ ss ct cl la old)


(setvar "cmdecho" 0)


(setq ss (ssget))


(setq ct 0

len (sslength ss)

cl (cdr (assoc 8 (entget (ssname ss 0))))

)


(setvar "clayer" cl)


(while (< ct len)


(setq la (cdr (assoc 8 (entget (ssname ss ct)))))


(if (= old nil)


(setq OLD la)


(setq OLD (strcat OLD "," la))

)


(setq ct (1+ ct))

)


(command ".layer" "off" "*" "n" "")


(command ".layer" "on" old "")


(setvar "CECOLOR" (itoa (cdr (assoc 62 (tblsearch "layer" (getvar "CLAYER"))))))

(princ)

)

vitalgg

源码：
https://gitee.com/atlisp/packages/blob/main/at-layer/at-layer.lsp

1. (@:add-menus '("图层"
   
2.          ("关闭其它" "(@layer:off-other)")
   
3.          ("冻结其它" "(@layer:frozen-other)")
   
4.          ("锁定其它" "(@layer:lock-other)")
   
5.          ("解锁全部" "(@layer:unlock-all)")
   
6.          ("解冻全部" "(@layer:thaw-all)")
   
7.          ("图层全开" "layon")
   
8.          ("图层恢复" "layerp")
   
9.          ("特性随层" "laycur")
   
10.          ("合并图层" "laymgr")
    
11.          ("删除图层" "laydel")
    
12.          ("图层漫游" "laywalk")
    
13.          ("选图进层" "(@layer:ent-to-clayer)")
    
14. 
    
15.          ))
    
16. ;; (@:add-menu "图层" "常用命令" "(@layer:ent-to-clayer)")
    
17. 
    
18. (defun @layer:get-layers-by-ss(ss / layer ti% ename e)
    
19.   "根据所选对象生成图层表"
    
20.   (setq layer nil )
    
21.   (setq ti% 0)
    
22.   (if (/= ss nil)
    
23.       (progn
    
24.         (while
    
25.             (<= ti% (- (sslength ss) 1))
    
26.           (setq ename (ssname ss ti%))
    
27.           (setq e (entget ename ))
    
28.           (if (=  (member (cdr (assoc 8 e)) layer) nil)
    
29.               (progn
    
30.                 (if (= layer nil)
    
31.                     (setq layer (list (cdr (assoc 8 e))))
    
32.                   (setq layer (append layer (list (cdr (assoc 8 e)))))
    
33.                   )
    
34.                 )
    
35.             )
    
36.           (setq ti%(+ 1 ti%))
    
37.           )))
    
38.   layer
    
39.   )
    
40. (defun @layer:off-other( /  ss  layer  lay-act-list )
    
41.   "关闭其它图层"
    
42.   (setq lay-act-list "")
    
43.   (setq ss (ssget ))
    
44.   (foreach layer (layer:list)
    
45.            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
    
46.            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)
    
47.                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )
    
48.              )
    
49.            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)
    
50.                (if (= lay-act-list "")
    
51.                    (setq lay-act-list layer)
    
52.                  (setq lay-act-list (strcat lay-act-list "," layer)
    
53.              )
    
54.            )))
    
55.   (command "-layer" "off" lay-act-list "")
    
56.   )
    
57. 
    
58. (defun @layer:frozen-other( /  ss  layer  lay-act-list )
    
59.   "冻结其它图层"
    
60.   (setq lay-act-list "")
    
61.   (setq ss (ssget ))
    
62.   (foreach layer (layer:list)
    
63.            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
    
64.            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)
    
65.                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )
    
66.              )
    
67.            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)
    
68.                (if (= lay-act-list "")
    
69.                    (setq lay-act-list layer)
    
70.                  (setq lay-act-list (strcat lay-act-list "," layer)
    
71.              )
    
72.            )))
    
73.   (command "-layer" "f" lay-act-list "")
    
74.   )
    
75. 
    
76. (defun @layer:lock-other( /  ss  layer  lay-act-list )
    
77.   "锁定其它图层"
    
78.   (setq lay-act-list "")
    
79.   (setq ss (ssget ))
    
80.   (foreach layer (layer:list)
    
81.            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
    
82.            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)
    
83.                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )
    
84.              )
    
85.            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)
    
86.                (if (= lay-act-list "")
    
87.                    (setq lay-act-list layer)
    
88.                  (setq lay-act-list (strcat lay-act-list "," layer)
    
89.              )
    
90.            )))
    
91.   (command "-layer" "lo" lay-act-list "")
    
92.   )
    
93. 
    
94. (defun @layer:unlock-all( /  ss  layer  lay-act-list )
    
95.    "解锁全部图层"
    
96.   (setq lay-act-list "")
    
97.   (foreach layer (layer:list)
    
98.            (if (= lay-act-list "")
    
99.                    (setq lay-act-list layer)
    
100.                  (setq lay-act-list (strcat lay-act-list "," layer)
     
101.              )
     
102.            ))
     
103.   (command "-layer" "u" lay-act-list "")
     
104.   )
     
105. 
     
106. (defun @layer:thaw-all( /  layer  lay-act-list )
     
107.   "解冻全部图层"
     
108.   (setq lay-act-list "")
     
109.   (foreach layer (layer:list)
     
110.            (if (= lay-act-list "")
     
111.                    (setq lay-act-list layer)
     
112.                  (setq lay-act-list (strcat lay-act-list "," layer)
     
113.              )
     
114.            ))
     
115.   (command "-layer" "t" lay-act-list "")
     
116.   )
     
117. 
     
118. (defun @layer:ent-to-clayer ()
     
119.   (if (null layer:list)(require 'layer:*))
     
120.   (if curr-layer
     
121.       (cond
     
122.        ((= 'int (type curr-layer))
     
123.   (setvar "clayer" (itoa curr-layer)))
     
124.        ((= 'str (type curr-layer))
     
125.   (if (null (member curr-layer (layer:list)))
     
126.       (layer:make curr-layer nil nil nil))
     
127.   (setvar "clayer" curr-layer))
     
128.        ((atom curr-layer)
     
129.   (if (null (member (vl-symbol-name curr-layer) (layer:list)))
     
130.       (layer:make (vl-symbol-name curr-layer) nil nil nil))
     
131.   (setvar "clayer" (vl-symbol-name curr-layer)))))
     
132.   (@:help (list
     
133.      (strcat "选择对象到" (getvar "clayer") "层")))
     
134.   (if (setq ss-curr (cadr (ssgetfirst)))
     
135.       (foreach ent (pickset:to-list ss-curr)
     
136.          (entity:putdxf ent 8 (getvar "clayer"))
     
137.          (entity:deldxf ent 6 )
     
138.          (entity:deldxf ent 48)
     
139.          (entity:deldxf ent 62)
     
140.          )
     
141.     (while (setq ent (car (entsel)))
     
142.       (entity:putdxf ent 8 (getvar "clayer"))
     
143.       (entity:deldxf ent 6 )
     
144.       (entity:deldxf ent 48)
     
145.       (entity:deldxf ent 62)
     
146.       ))
     
147.   (setq curr-layer nil)
     
148.   )
     
149. (defun c:ent2clayer ()
     
150.   (@layer:ent-to-clayer))
     
151. 
     

(@:add-menus '("图层"<br />          ("关闭其它" "(@layer:off-other)")<br />          ("冻结其它" "(@layer:frozen-other)")<br />          ("锁定其它" "(@layer:lock-other)")<br />          ("解锁全部" "(@layer:unlock-all)")<br />          ("解冻全部" "(@layer:thaw-all)")<br />          ("图层全开" "layon")<br />          ("图层恢复" "layerp")<br />          ("特性随层" "laycur")<br />          ("合并图层" "laymgr")<br />          ("删除图层" "laydel")<br />          ("图层漫游" "laywalk")<br />          ("选图进层" "(@layer:ent-to-clayer)")<br /> <br />          ))<br /> ;; (@:add-menu "图层" "常用命令" "(@layer:ent-to-clayer)")<br /> <br /> (defun @layer:get-layers-by-ss(ss / layer ti% ename e)<br />   "根据所选对象生成图层表"<br />   (setq layer nil )<br />   (setq ti% 0)<br />   (if (/= ss nil)<br />       (progn <br />         (while<br />             (<= ti% (- (sslength ss) 1))<br />           (setq ename (ssname ss ti%))<br />           (setq e (entget ename ))<br />           (if (=  (member (cdr (assoc 8 e)) layer) nil)<br />               (progn<br />                 (if (= layer nil)<br />                     (setq layer (list (cdr (assoc 8 e))))<br />                   (setq layer (append layer (list (cdr (assoc 8 e)))))<br />                   )<br />                 )<br />             )<br />           (setq ti%(+ 1 ti%))<br />           )))<br />   layer<br />   )<br /> (defun @layer:off-other( /  ss  layer  lay-act-list )<br />   "关闭其它图层"<br />   (setq lay-act-list "")<br />   (setq ss (ssget ))<br />   (foreach layer (layer:list)<br />            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层<br />            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)<br />                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )<br />              )<br />            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)<br />                (if (= lay-act-list "")<br />                    (setq lay-act-list layer)<br />                  (setq lay-act-list (strcat lay-act-list "," layer)<br />              )<br />            )))<br />   (command "-layer" "off" lay-act-list "")<br />   )<br /> <br /> (defun @layer:frozen-other( /  ss  layer  lay-act-list )<br />   "冻结其它图层"<br />   (setq lay-act-list "")<br />   (setq ss (ssget ))<br />   (foreach layer (layer:list)<br />            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层<br />            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)<br />                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )<br />              )<br />            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)<br />                (if (= lay-act-list "")<br />                    (setq lay-act-list layer)<br />                  (setq lay-act-list (strcat lay-act-list "," layer)<br />              )<br />            )))<br />   (command "-layer" "f" lay-act-list "")<br />   )<br /> <br /> (defun @layer:lock-other( /  ss  layer  lay-act-list )<br />   "锁定其它图层"<br />   (setq lay-act-list "")<br />   (setq ss (ssget ))<br />   (foreach layer (layer:list)<br />            ;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层<br />            (if (= (member (getvar "clayer")  (@layer:get-layers-by-ss ss)) nil)<br />                (setvar "clayer" (car  (@layer:get-layers-by-ss ss)) )<br />              )<br />            (if (= (member layer (@layer:get-layers-by-ss ss)) nil)<br />                (if (= lay-act-list "")<br />                    (setq lay-act-list layer)<br />                  (setq lay-act-list (strcat lay-act-list "," layer)<br />              )<br />            )))<br />   (command "-layer" "lo" lay-act-list "")<br />   )<br /> <br /> (defun @layer:unlock-all( /  ss  layer  lay-act-list )<br />    "解锁全部图层"<br />   (setq lay-act-list "")<br />   (foreach layer (layer:list)<br />            (if (= lay-act-list "")<br />                    (setq lay-act-list layer)<br />                  (setq lay-act-list (strcat lay-act-list "," layer)<br />              )<br />            ))<br />   (command "-layer" "u" lay-act-list "")<br />   )<br /> <br /> (defun @layer:thaw-all( /  layer  lay-act-list )<br />   "解冻全部图层"<br />   (setq lay-act-list "")<br />   (foreach layer (layer:list)<br />            (if (= lay-act-list "")<br />                    (setq lay-act-list layer)<br />                  (setq lay-act-list (strcat lay-act-list "," layer)<br />              )<br />            ))<br />   (command "-layer" "t" lay-act-list "")<br />   )<br /> <br /> (defun @layer:ent-to-clayer ()<br />   (if (null layer:list)(require 'layer:*))<br />   (if curr-layer<br />       (cond<br />        ((= 'int (type curr-layer))<br />   (setvar "clayer" (itoa curr-layer)))<br />        ((= 'str (type curr-layer))<br />   (if (null (member curr-layer (layer:list)))<br />       (layer:make curr-layer nil nil nil))<br />   (setvar "clayer" curr-layer))<br />        ((atom curr-layer)<br />   (if (null (member (vl-symbol-name curr-layer) (layer:list)))<br />       (layer:make (vl-symbol-name curr-layer) nil nil nil))<br />   (setvar "clayer" (vl-symbol-name curr-layer)))))<br />   (@:help (list<br />      (strcat "选择对象到" (getvar "clayer") "层")))<br />   (if (setq ss-curr (cadr (ssgetfirst)))<br />       (foreach ent (pickset:to-list ss-curr)<br />          (entity:putdxf ent 8 (getvar "clayer"))<br />          (entity:deldxf ent 6 )<br />          (entity:deldxf ent 48)<br />          (entity:deldxf ent 62)<br />          )<br />     (while (setq ent (car (entsel)))<br />       (entity:putdxf ent 8 (getvar "clayer"))<br />       (entity:deldxf ent 6 )<br />       (entity:deldxf ent 48)<br />       (entity:deldxf ent 62)<br />       ))<br />   (setq curr-layer nil)<br />   )<br /> (defun c:ent2clayer ()<br />   (@layer:ent-to-clayer))<br /> <br />

cj52000

kucha007 发表于 2024-1-28 14:28
试试这个

大佬，工作需要这个能不能多选呢，烦请帮忙看看

wzg356

CAD自带啦，在工具条

弥勒

(defun c:kkk (/ ee  nk n1 n2 n3 n4 n5 n ent)
   (setvar "cmdecho" 0)
   (setq ee (car (entsel " 选择保留单个层，关闭其他层 ")))
   (setq nk (cdr(assoc 8 (entget ee))))
   (setq n1 (ssget "X"))
   (setq n2 (sslength n1))
   (command "layer" "off" "*" "y" "")
   (setq n 0)
   (while (> n2 n)
     (setq ent (ssname n1 n))
     (setq n3 (assoc 8 (entget ent)))
     (setq n5 (cdr n3))
        (if (equal nk n5)
              (command "layer" "on" n5   "")
        )
     (setq n (+ 1 n))
         (princ)
   )
)

弥勒

和尚我懂你！我佛慈悲

cj52000

弥勒 发表于 2024-1-28 22:24
和尚我懂你！我佛慈悲

大慈大悲，大佬你这个还是只能开单个，而且选中后运行很卡顿，再帮忙看看

弥勒

kucha007

cj52000 发表于 2024-1-28 15:29
大佬，工作需要这个能不能多选呢，烦请帮忙看看

已改写，再看看