如下代码可以把所有图快变成8号色，但是把图层全部设置成了dxt图层，请问如何不改...

yangchao2005090 · 发表于 2020-5-22 23:39:20

本帖最后由 yangchao2005090 于 2020-5-22 23:40 编辑

如下代码可以把所有图快变成8号色，但是把图层全部设置成了dxt图层，请问如何不改变原始图层

(Defun c:t2 (/ ss ss1 ss2 n ex ext color layer i colot layer)
;; 主程序
(vl-load-com)
(setq color 8 layer "dxt")
(if (=(tblsearch "layer" layer)nil)(progn
(command "layer" "N" layer "c" color layer "")));;如果没有dxt层就创建新的dxt层
(princ "\n选要变更颜色的图形: ")
(setq ss(ssget))
(setq n (sslength ss))
(setq i 0)
(setq ss1(ssadd))
(setq ss2(ssadd))
(while (< i n)
(setq ex (ssname ss i))
(setq ext (cdr(assoc 0 (entget ex))))
(if (= ext "INSERT") (progn (setq ss1(ssadd ex ss1))));;创建一个新的选集，只包含图块
(if (/= ext "INSERT") (progn (setq ss2(ssadd ex ss2))));;创建一个新的选集，包含除了块以外的所有图形
(setq i(+ i 1)))
(sub_block ss1)
(sub_xxx ss2 layer color)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;子程序1
(defun sub_xxx(ss2 layer color / nxt et i n2)
(setq n2 (sslength ss2))
(setq i 0)
(while (< i n2)
(setq et (ssname ss2 i))
(setq nxt(entget et))
(setq nxt (subst (cons 8 layer)(assoc 8 nxt) nxt ));;变更图层
(setq nxt (subst (cons 62 256)(assoc 62 nxt) nxt ));;改变颜色随层
(entmod nxt)
(setq i(+ i 1))))
;;子程序2
(defun sub_block(ss1 / i bolcks vn n1 )
(setq n1 (sslength ss1))
;;; (setq ss1 (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))
;;; (cond ((or (vl-catch-all-error-p ss1) (null ss1)) (vl-exit-with-value 0)))
(setq i 0
*AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))
blocks (vla-get-blocks *AcadDocument*)
)
(repeat n1
(setq vn (vlax-ename->vla-object (ssname ss1 i))
i (1+ i))
;; 防止出错 .
(sub_Fun vn)
)
(prin1)
)
;; 子程序2-1
(Defun sub_Fun (vn)
(vla-put-color vn color)
(vla-put-layer vn layer)
(vlax-for ent (vla-item blocks (vla-get-name vn))
(vla-put-color ent color)
(vla-put-layer ent layer)
(if (= (vla-get-objectname ent) "AcDbBlockReference")
(sub_Fun ent)
)
)
)

(Defun c:t2 (/ ss ss1 ss2  n ex ext color layer i  colot layer) 
  ;; 主程序 
  (vl-load-com) 
  (setq color 8 layer "dxt") 
  (if (=(tblsearch "layer" layer)nil)(progn 
  (command "layer" "N" layer "c" color layer "")));;如果没有dxt层就创建新的dxt层 
  (princ "\n选要变更颜色的图形: ") 
  (setq ss(ssget)) 
  (setq n (sslength ss)) 
  (setq i 0) 
  (setq ss1(ssadd)) 
  (setq ss2(ssadd)) 
  (while (
  (setq ex (ssname ss i)) 
  (setq ext (cdr(assoc 0 (entget ex)))) 
    (if (= ext "INSERT") (progn (setq ss1(ssadd ex ss1))));;创建一个新的选集，只包含图块 
    (if (/= ext "INSERT") (progn (setq ss2(ssadd ex ss2))));;创建一个新的选集，包含除了块以外的所有图形 
   (setq i(+ i 1))) 
  (sub_block ss1) 
  (sub_xxx ss2 layer color) 
  (princ) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;子程序1 
(defun sub_xxx(ss2 layer color / nxt et i n2) 
  (setq n2 (sslength ss2)) 
  (setq i 0) 
  (while (
  (setq et (ssname ss2 i)) 
  (setq nxt(entget et)) 
  (setq nxt (subst (cons 8 layer)(assoc 8 nxt) nxt ));;变更图层 
  (setq nxt (subst (cons 62 256)(assoc 62 nxt) nxt ));;改变颜色随层 
  (entmod nxt) 
  (setq i(+ i 1)))) 
 
   
   
;;子程序2 
  (defun sub_block(ss1 / i bolcks vn n1 ) 
    (setq n1 (sslength ss1)) 
;;;  (setq ss1 (vl-catch-all-apply 'ssget '(((0 . "INSERT"))))) 
;;;  (cond ((or (vl-catch-all-error-p ss1) (null ss1)) (vl-exit-with-value 0))) 
  (setq i 0 
        *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object)) 
         blocks        (vla-get-blocks *AcadDocument*) 
  ) 
  (repeat n1 
    (setq vn (vlax-ename->vla-object (ssname ss1 i)) 
          i  (1+ i)) 
    ;; 防止出错 . 
    (sub_Fun vn) 
    ) 
  (prin1) 
) 
 
 
  ;; 子程序2-1 
  (Defun sub_Fun (vn) 
    (vla-put-color vn color) 
    (vla-put-layer vn layer) 
    (vlax-for ent (vla-item blocks (vla-get-name vn)) 
      (vla-put-color ent color) 
      (vla-put-layer ent layer) 
      (if (= (vla-get-objectname ent) "AcDbBlockReference") 
 (sub_Fun ent) 
      ) 
    ) 
  )

代码来源于本论坛，附件内容一样

start4444 · 发表于 2020-5-23 00:21:28

看看行不。。

434939575 · 发表于 2020-5-23 09:31:30

[code=lisp](Defun c:t2 (/ ss ss1 ss2 n ex ext color layer i colot layer)
;; 主程序
(vl-load-com)
(setq color 8 layer "dxt")
(if (=(tblsearch "layer" layer)nil)(progn
(command "layer" "N" layer "c" color layer "")));;如果没有dxt层就创建新的dxt层
(princ "\n选要变更颜色的图形: ")
(setq ss(ssget))
(setq n (sslength ss))
(setq i 0)
(setq ss1(ssadd))
(setq ss2(ssadd))
(while (< i n)
(setq ex (ssname ss i))
(setq ext (cdr(assoc 0 (entget ex))))
(if (= ext "INSERT") (progn (setq ss1(ssadd ex ss1))));;创建一个新的选集，只包含图块
(if (/= ext "INSERT") (progn (setq ss2(ssadd ex ss2))));;创建一个新的选集，包含除了块以外的所有图形
(setq i(+ i 1)))
(sub_block ss1)
(sub_xxx ss2 layer color)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;子程序1
(defun sub_xxx(ss2 layer color / nxt et i n2)
(setq n2 (sslength ss2))
(setq i 0)
(while (< i n2)
(setq et (ssname ss2 i))
(setq nxt(entget et))
;(setq nxt (subst (cons 8 layer)(assoc 8 nxt) nxt ));;变更图层
(setq nxt (subst (cons 62 256)(assoc 62 nxt) nxt ));;改变颜色随层
(entmod nxt)
(setq i(+ i 1))))
;;子程序2
(defun sub_block(ss1 / i bolcks vn n1 )
(setq n1 (sslength ss1))
;;; (setq ss1 (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))
;;; (cond ((or (vl-catch-all-error-p ss1) (null ss1)) (vl-exit-with-value 0)))
(setq i 0
*AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))
blocks (vla-get-blocks *AcadDocument*)
)
(repeat n1
(setq vn (vlax-ename->vla-object (ssname ss1 i))
i (1+ i))
;; 防止出错 .
(sub_Fun vn)
)
(prin1)
)
;; 子程序2-1
(Defun sub_Fun (vn)
(vla-put-color vn color)
; (vla-put-layer vn layer);;变更图层
(vlax-for ent (vla-item blocks (vla-get-name vn))
(vla-put-color ent color)
;(vla-put-layer ent layer);;变更图层
(if (= (vla-get-objectname ent) "AcDbBlockReference")
(sub_Fun ent)
)
)
)

[code=lisp](Defun c:t2 (/ ss ss1 ss2  n ex ext color layer i  colot layer) 
  ;; 主程序 
  (vl-load-com) 
  (setq color 8 layer "dxt") 
  (if (=(tblsearch "layer" layer)nil)(progn 
  (command "layer" "N" layer "c" color layer "")));;如果没有dxt层就创建新的dxt层 
  (princ "\n选要变更颜色的图形: ") 
  (setq ss(ssget)) 
  (setq n (sslength ss)) 
  (setq i 0) 
  (setq ss1(ssadd)) 
  (setq ss2(ssadd)) 
  (while (
  (setq ex (ssname ss i)) 
  (setq ext (cdr(assoc 0 (entget ex)))) 
    (if (= ext "INSERT") (progn (setq ss1(ssadd ex ss1))));;创建一个新的选集，只包含图块 
    (if (/= ext "INSERT") (progn (setq ss2(ssadd ex ss2))));;创建一个新的选集，包含除了块以外的所有图形 
   (setq i(+ i 1))) 
  (sub_block ss1) 
  (sub_xxx ss2 layer color) 
  (princ) 
  ) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;子程序1 
(defun sub_xxx(ss2 layer color / nxt et i n2) 
  (setq n2 (sslength ss2)) 
  (setq i 0) 
  (while (
  (setq et (ssname ss2 i)) 
  (setq nxt(entget et)) 
  ;(setq nxt (subst (cons 8 layer)(assoc 8 nxt) nxt ));;变更图层 
  (setq nxt (subst (cons 62 256)(assoc 62 nxt) nxt ));;改变颜色随层 
  (entmod nxt) 
  (setq i(+ i 1)))) 
 
   
   
;;子程序2 
  (defun sub_block(ss1 / i bolcks vn n1 ) 
    (setq n1 (sslength ss1)) 
;;;  (setq ss1 (vl-catch-all-apply 'ssget '(((0 . "INSERT"))))) 
;;;  (cond ((or (vl-catch-all-error-p ss1) (null ss1)) (vl-exit-with-value 0))) 
  (setq i 0 
        *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object)) 
         blocks        (vla-get-blocks *AcadDocument*) 
  ) 
  (repeat n1 
    (setq vn (vlax-ename->vla-object (ssname ss1 i)) 
          i  (1+ i)) 
    ;; 防止出错 . 
    (sub_Fun vn) 
    ) 
  (prin1) 
) 
 
 
  ;; 子程序2-1 
  (Defun sub_Fun (vn) 
    (vla-put-color vn color) 
   ; (vla-put-layer vn layer);;变更图层 
    (vlax-for ent (vla-item blocks (vla-get-name vn)) 
      (vla-put-color ent color) 
      ;(vla-put-layer ent layer);;变更图层 
      (if (= (vla-get-objectname ent) "AcDbBlockReference") 
(sub_Fun ent) 
      ) 
    ) 
  )

[/code]

yangchao2005090 · 发表于 2020-5-23 10:50:42

start4444 发表于 2020-5-23 00:21
看看行不。。

可以的，谢谢，还想请教一下，想快速删掉附件中不同图块内的填充可以实现吗

yangchao2005090 · 发表于 2020-5-23 10:51:31

434939575 发表于 2020-5-23 09:31
[/code]

可以的，谢谢，还想请教一下，想快速删掉附件中不同图块内的填充可以实现吗

yangchao2005090 · 发表于 2020-7-17 07:57:04

start4444 发表于 2020-5-23 00:21
看看行不。。

谢谢你，可以的

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

[提问] 如下代码可以把所有图快变成8号色，但是把图层全部设置成了dxt图层，请问如何不改...

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源