【求助】块归0层并改色

smartstar

我找到一个块归0层并改色的lsp程序，如下：

(defun C:FIXBLOCK (/ COL SS CNT IDX BLKNAME DONELIST)
  (defun GRP (GCC EL) (cdr (assoc GCC EL)))
  (defun UPDATE        (BNAME COL / ENAME ELIST)
    (setq ENAME (tblobjname "BLOCK" BNAME))
    (if
      (and ENAME
           (zerop (logand 52 (GRP 70 (entget ENAME '("*")))))
      )
       (progn
         (while        ENAME
           (if (or (= "INSERT" (GRP 0 (entget ENAME)))
                   (= "DIMENSION" (GRP 0 (entget ENAME)))
               )
             (UPDATE (GRP 2 (entget ENAME)) COL)
           )
           (setq ELIST (entget ENAME '("*"))
                 ELIST (subst '(8 . "0") (assoc 8 ELIST) ELIST)
                 ELIST (if (assoc 62 ELIST)
                         (subst (cons 62 COL) (assoc 62 ELIST) ELIST)
                         (append ELIST (list (cons 62 COL)))
                       )
           )
           (entmod ELIST)
           (setq ENAME (entnext ENAME))
         )
         't
       )
    )
  )
  (if (> (logand (GRP 70 (tblsearch "layer" "0")) 1) 0)
    (princ "\nLayer 0 must be thawed before running FIXBLOCK!\n")
    (progn
      (if
        (progn
          (setq COL (acad_colordlg 7))
          (princ "\nPress  to fix all Blocks New Color\n")
          (setq        CNT 0
                SS  (ssget '((0 . "INSERT,DIMENSION")))
          )
        )
         (progn
           (setq IDX (sslength SS))
           (while (>= (setq IDX (1- IDX)) 0)
             (if
               (not
                 (member (setq BLKNAME (GRP 2 (entget (ssname SS IDX))))
                         DONELIST
                 )
               )
                (progn
                  (if (UPDATE BLKNAME COL)
                    (setq CNT (1+ CNT))
                  )
                  (setq DONELIST (cons BLKNAME DONELIST))
                )
             )
           )
         )
         (while        (setq BLKNAME (GRP 2 (tblnext "BLOCK" (not BLKNAME))))
           (if (UPDATE BLKNAME COL)
             (setq CNT (1+ CNT))
           )
         )
      )
      (princ (strcat "\n"
                     (itoa CNT)
                     " block"
                     (if (= CNT 1)
                       ""
                       "s"
                     )
                     " redefined New Color\n"
             )
      )
    )
  )
  (command "_.REGEN")
  (princ)
)
(princ "“块改色”程序已经加载 ! 输入 FIXBLOCK 执行")
(princ)

求增加功能：
第一个：能达到上述lsp程序颜色和图层功能，但线型保持不变（线宽最好也保存不变）。
第二个：能达到上述lsp程序颜色功能，但图层和线型保持不变（线宽最好也保存不变）。

smartstar

继续等待高人解答……

dz-2011

明经本就是个百科全书样的论坛，有些问题学会自已找下能找到的，修改块颜色本很简单，你写复杂了！

smartstar

yjr111
你好，你的工具很好，但是如果块中有标注，不能很好的处理哦！

smartstar

标注文字的颜色不能改色

pzweng

(defun C:Clay ()
  (vl-load-com)
  (setq myacad (vlax-get-acad-object))
  (setq mydoc (vla-get-activedocument myacad))
  (setq myblock (vla-get-blocks mydoc))
  (vlax-for obj        myblock
    (setq blocks (cons (vla-get-name obj) blocks))
  )
  (setq        blocks (vl-remove-if
                 '(lambda (x)
                    (or        (wcmatch x "*Paper_Space*")
                        (wcmatch x "*Model_Space*")
                    )
                  )
                 blocks
               )
  )
  (foreach x blocks
    (vlax-for ent (vla-item myblock x)
     (vla-put-layer ent "0")
;;;      (setq dat (entget (vlax-vla-object->ename ent)))
;;;      (setq dat (subst (cons 8 "0") (assoc 8 dat)dat))
;;;      (entmod dat)
;;;      (entupd (vlax-vla-object->ename ent))
    )
  )
  (princ)
)

start4444