帮忙修改下程序，选物单开图层并将此物图层置为当前
各位大佬，以下程序为选物单开图层，但是选中物体的图层不能置为当前，请帮忙修改下将选中物体的图层置为当前，谢谢！
(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 于 2024-1-29 11:05 编辑
试试这个
;关闭其它图层并将目标图层置为当前
(defun c:TT (/ DOC LayLst SS i obj Lay LayOpen en TgtLay)
(if (null vlax-dump-object) (vl-load-com));;将Visual LISP扩展功能加载到AutoLISP
(setq DOC (vla-get-activedocument (vlax-get-acad-object))
LayLst (vla-get-layers DOC)
)
(defun *error* (Msg)
(vla-endundomark DOC)
)
(while (eq 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark DOC)
) ;关闭以前的编组
(vla-startundomark DOC) ;记录编组
(if
(and
(princ "\n——★★★ 请选择需要保留图层的对象 ★★★——\n")
(setq SS (ssget))
)
(progn
(vlax-for XX LayLst (vla-put-layeron XX :vlax-false)) ;图层全关
(repeat (setq i (sslength SS))
(setq obj (vlax-ename->vla-object (ssname SS (setq i (1- i))))
Lay (vla-get-Layer obj)
)
(if (not (vl-position Lay LayOpen))
(progn
(vla-put-layeron (vla-item LayLst Lay) :vlax-true) ;打开目标图层
(setq LayOpen (cons Lay LayOpen))
)
)
);关闭其它
(princ "\n——★★★ 已关闭除所选对象以外的其它图层 ★★★——\n")
(if (setq en (car (entsel "\n→请点选目标图层的对象：")))
(progn
(setq TgtLay (Vlax-Get (Vlax-Ename->Vla-Object en) 'Layer)) ;获取目标图层
(setvar "CLAYER" TgtLay) ;图层置为当前
(princ (strcat "\n——★★★ 目标图层<" TgtLay ">已置为当前 ★★★——\n"))
)
)
)
)
(vla-endundomark DOC) ;结束编组
(command "redraw")
(princ)
)
试试这个
(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 于 2024-1-28 21:51 编辑
源码：
https://gitee.com/atlisp/packages/blob/main/at-layer/at-layer.lsp
(@:add-menus '("图层"
("关闭其它" "(@layer:off-other)")
("冻结其它" "(@layer:frozen-other)")
("锁定其它" "(@layer:lock-other)")
("解锁全部" "(@layer:unlock-all)")
("解冻全部" "(@layer:thaw-all)")
("图层全开" "layon")
("图层恢复" "layerp")
("特性随层" "laycur")
("合并图层" "laymgr")
("删除图层" "laydel")
("图层漫游" "laywalk")
("选图进层" "(@layer:ent-to-clayer)")
))
;; (@:add-menu "图层" "常用命令" "(@layer:ent-to-clayer)")
(defun @layer:get-layers-by-ss(ss / layer ti% ename e)
"根据所选对象生成图层表"
(setq layer nil )
(setq ti% 0)
(if (/= ss nil)
(progn
(while
(<= ti% (- (sslength ss) 1))
(setq ename (ssname ss ti%))
(setq e (entget ename ))
(if (=(member (cdr (assoc 8 e)) layer) nil)
(progn
(if (= layer nil)
(setq layer (list (cdr (assoc 8 e))))
(setq layer (append layer (list (cdr (assoc 8 e)))))
)
)
)
(setq ti%(+ 1 ti%))
)))
layer
)
(defun @layer:off-other( /sslayerlay-act-list )
"关闭其它图层"
(setq lay-act-list "")
(setq ss (ssget ))
(foreach layer (layer:list)
;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
(if (= (member (getvar "clayer")(@layer:get-layers-by-ss ss)) nil)
(setvar "clayer" (car(@layer:get-layers-by-ss ss)) )
)
(if (= (member layer (@layer:get-layers-by-ss ss)) nil)
(if (= lay-act-list "")
(setq lay-act-list layer)
(setq lay-act-list (strcat lay-act-list "," layer)
)
)))
(command "-layer" "off" lay-act-list "")
)
(defun @layer:frozen-other( /sslayerlay-act-list )
"冻结其它图层"
(setq lay-act-list "")
(setq ss (ssget ))
(foreach layer (layer:list)
;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
(if (= (member (getvar "clayer")(@layer:get-layers-by-ss ss)) nil)
(setvar "clayer" (car(@layer:get-layers-by-ss ss)) )
)
(if (= (member layer (@layer:get-layers-by-ss ss)) nil)
(if (= lay-act-list "")
(setq lay-act-list layer)
(setq lay-act-list (strcat lay-act-list "," layer)
)
)))
(command "-layer" "f" lay-act-list "")
)
(defun @layer:lock-other( /sslayerlay-act-list )
"锁定其它图层"
(setq lay-act-list "")
(setq ss (ssget ))
(foreach layer (layer:list)
;;; 如果当前图层不在 所选对象中，设当前层为第一个当前对象层
(if (= (member (getvar "clayer")(@layer:get-layers-by-ss ss)) nil)
(setvar "clayer" (car(@layer:get-layers-by-ss ss)) )
)
(if (= (member layer (@layer:get-layers-by-ss ss)) nil)
(if (= lay-act-list "")
(setq lay-act-list layer)
(setq lay-act-list (strcat lay-act-list "," layer)
)
)))
(command "-layer" "lo" lay-act-list "")
)
(defun @layer:unlock-all( /sslayerlay-act-list )
"解锁全部图层"
(setq lay-act-list "")
(foreach layer (layer:list)
(if (= lay-act-list "")
(setq lay-act-list layer)
(setq lay-act-list (strcat lay-act-list "," layer)
)
))
(command "-layer" "u" lay-act-list "")
)
(defun @layer:thaw-all( /layerlay-act-list )
"解冻全部图层"
(setq lay-act-list "")
(foreach layer (layer:list)
(if (= lay-act-list "")
(setq lay-act-list layer)
(setq lay-act-list (strcat lay-act-list "," layer)
)
))
(command "-layer" "t" lay-act-list "")
)
(defun @layer:ent-to-clayer ()
(if (null layer:list)(require 'layer:*))
(if curr-layer
(cond
((= 'int (type curr-layer))
(setvar "clayer" (itoa curr-layer)))
((= 'str (type curr-layer))
(if (null (member curr-layer (layer:list)))
(layer:make curr-layer nil nil nil))
(setvar "clayer" curr-layer))
((atom curr-layer)
(if (null (member (vl-symbol-name curr-layer) (layer:list)))
(layer:make (vl-symbol-name curr-layer) nil nil nil))
(setvar "clayer" (vl-symbol-name curr-layer)))))
(@:help (list
(strcat "选择对象到" (getvar "clayer") "层")))
(if (setq ss-curr (cadr (ssgetfirst)))
(foreach ent (pickset:to-list ss-curr)
(entity:putdxf ent 8 (getvar "clayer"))
(entity:deldxf ent 6 )
(entity:deldxf ent 48)
(entity:deldxf ent 62)
)
(while (setq ent (car (entsel)))
(entity:putdxf ent 8 (getvar "clayer"))
(entity:deldxf ent 6 )
(entity:deldxf ent 48)
(entity:deldxf ent 62)
))
(setq curr-layer nil)
)
(defun c:ent2clayer ()
(@layer:ent-to-clayer))
kucha007 发表于 2024-1-28 14:28
试试这个
大佬，工作需要这个能不能多选呢，烦请帮忙看看 CAD自带啦，在工具条
(defun c:kkk (/ eenk 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)
)
)
本帖最后由 弥勒 于 2024-1-28 22:52 编辑
和尚我懂你！我佛慈悲 弥勒 发表于 2024-1-28 22:24
和尚我懂你！我佛慈悲
大慈大悲，大佬你这个还是只能开单个，而且选中后运行很卡顿，再帮忙看看 :handshake cj52000 发表于 2024-1-28 15:29
大佬，工作需要这个能不能多选呢，烦请帮忙看看
已改写，再看看