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

cj52000 · 发表于 2024-1-29 13:40:24

kucha007 发表于 2024-1-29 11:06
已改写，再看看

可以多选了，但是图层不能置为当前，比如选中3个图层单开，使其任意1个图层置为当前都行

kucha007 · 发表于 2024-1-29 13:57:32

cj52000 发表于 2024-1-29 13:40
可以多选了，但是图层不能置为当前，比如选中3个图层单开，使其任意1个图层置为当前都行

你任意图层都行是吧……多个对象也是随机一个图层就行？

cj52000 · 发表于 2024-1-29 14:15:49

kucha007 发表于 2024-1-29 13:57
你任意图层都行是吧……多个对象也是随机一个图层就行？

嗯嗯，是的大佬

kucha007 · 发表于 2024-1-29 14:23:51

cj52000 发表于 2024-1-29 14:15
嗯嗯，是的大佬

(defun c:TT (/ DOC LayLst SS i obj Lay LayOpen)
(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))
)
)
);关闭其它
(setvar "CLAYER" (car LayOpen)) ;图层置为当前
(princ "\n——★★★ 已关闭除所选对象以外的其它图层 ★★★——\n")
)
)
(vla-endundomark DOC) ;结束编组
(command "redraw")
(princ)
)

(defun c:TT (/ DOC LayLst SS i obj Lay LayOpen) 
  (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)) 
            ) 
          ) 
        );关闭其它 
        (setvar "CLAYER" (car LayOpen)) ;图层置为当前 
        (princ "\n——★★★ 已关闭除所选对象以外的其它图层 ★★★——\n") 
      ) 
    ) 
  (vla-endundomark DOC) ;结束编组 
  (command "redraw") 
  (princ) 
)

cj52000 · 发表于 2024-1-29 15:11:46

kucha007 发表于 2024-1-29 14:23

可以了，感谢！

paulpipi · 发表于 2024-1-29 17:30:38

vitalgg 发表于 2024-1-28 21:50
源码：
https://gitee.com/atlisp/packages/blob/main/at-layer/at-layer.lsp

看着挺好，不知道咋用

vitalgg · 发表于 2024-1-29 17:44:28

paulpipi 发表于 2024-1-29 17:30
看着挺好，不知道咋用

想直接用更简单。
复制以下代码到CAD命令行，回车安装即可。

(progn(vl-load-com)(setq s strcat h "http" o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://atlisp.""cn/@"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))

bai2000 · 发表于 2024-1-29 18:39:54

kucha007 发表于 2024-1-29 14:23

不错，正常使用，能加个不选对象时回车后恢复图层会更方便一点

zhufeng1004 · 发表于 2024-1-29 20:47:34

试试这个

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

)

paulpipi · 发表于 2024-1-29 22:50:47

kucha007 发表于 2024-1-29 14:23

真好用，感谢分享

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

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

评分