smartstar 发表于 2012-4-26 13:02:25

【求助】块归0层并改色

本帖最后由 smartstar 于 2012-4-26 18:41 编辑

我找到一个块归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 "\nPressto 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 发表于 2012-4-27 20:40:14

继续等待高人解答……

dz-2011 发表于 2012-4-27 23:18:54

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

smartstar 发表于 2012-4-30 11:12:59

本帖最后由 smartstar 于 2012-4-30 11:13 编辑

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

smartstar 发表于 2012-4-30 12:24:05

标注文字的颜色不能改色

pzweng 发表于 2013-2-3 15:18:34

(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 发表于 2017-12-21 17:25:58

页: [1]
查看完整版本: 【求助】块归0层并改色