大家帮我看下这个改图块颜色程序如何完善下！

cj52000

大家好：

            现有一个改图块颜色的程序，因为工作中会插入很多相同的块，我目的是想单独改某一个块的颜色，而这个程序是你点个某个块后，图档中所有的相同块颜色都变了，请大家帮完善一下，谢谢各位！


(defun C:Y6 (/ 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)
)

依然小小鸟

cj52000 发表于 2015-4-17 18:03
还是不行啊，改一个块颜色，其实相同的块都改了

同样的需求 请问解决问题了吗

依然小小鸟

alexmai 发表于 2021-9-17 23:46
块颜色改为byblock

不太懂呢 怎么操作呢  有完整代码吗

alexmai

依然小小鸟 发表于 2021-9-9 14:28
同样的需求 请问解决问题了吗

块颜色改为byblock

cj52000

各位老大帮忙看看啊

lijiao

其实是不用编程的，利用ACAD的基本知识就可以达到目的。
ACAD的0层实际上是透明的，所以又叫透明层。
做法：1、将图元绘制在0层，颜色随层，然后定义图块。
         2、在不同的图层中插入图块，就会形成颜色与图层颜色相同的图块。

菜卷鱼

1. (defun LM:ApplytoBlockObjects ( blks name func / result )
   
2.     (setq func (eval func))
   
3.     (if (not (vl-catch-all-error-p (setq def (vl-catch-all-apply 'vla-item (list blks name)))))
   
4.         (vlax-for obj def (setq result (cons (func obj) result)))
   
5.     )
   
6.     (reverse result)
   
7. )
   
8. 
   
9. (defun c:bco ( / s col)
   
10. (if (= ocol nil)(setq ocol 0))
    
11.     (princ "\nSelect Block: ")
    
12.     (if (setq s (ssget "_+.:E:S" '((0 . "INSERT"))))
    
13. (progn
    
14. (mapcar 'princ (list "\nNumber of color:[<" ocol ">]"))
    
15. (prin1)
    
16.         (setq col(getint ))
    
17. (if (/= col nil)(setq ocol col)(setq col ocol))
    
18.         (LM:ApplytoBlockObjects
    
19.             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    
20.             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
    
21.            '(lambda ( obj ) (vla-put-layer obj "0"))        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;图层改为0层
    
22.         )
    
23.         (LM:ApplytoBlockObjects
    
24.             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    
25.             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
    
26.            '(lambda ( obj ) (vla-put-Color obj col))           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;颜色改为Col
    
27.         )
    
28.         (LM:ApplytoBlockObjects
    
29.             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
    
30.             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
    
31.            '(lambda ( obj ) (vla-put-LinetypeScale obj (getvar 'dimscale)))           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;顺便改一下线型比例
    
32.         )                                                               
    
33. )
    
34.     )
    
35.     (princ)
    
36. (entmod(entget(ssname s 0)))(princ)
    
37. )
    
38. (vl-load-com) (princ)

(defun LM:ApplytoBlockObjects ( blks name func / result )<br />     (setq func (eval func))<br />     (if (not (vl-catch-all-error-p (setq def (vl-catch-all-apply 'vla-item (list blks name)))))<br />         (vlax-for obj def (setq result (cons (func obj) result)))<br />     )<br />     (reverse result)<br /> )<br /> <br /> (defun c:bco ( / s col)<br /> (if (= ocol nil)(setq ocol 0))<br />     (princ "\nSelect Block: ")<br />     (if (setq s (ssget "_+.:E:S" '((0 . "INSERT"))))<br /> (progn<br /> (mapcar 'princ (list "\nNumber of color:[<" ocol ">]"))<br /> (prin1)<br />         (setq col(getint ))<br /> (if (/= col nil)(setq ocol col)(setq col ocol))<br />         (LM:ApplytoBlockObjects<br />             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))<br />             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))<br />            '(lambda ( obj ) (vla-put-layer obj "0"))        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;图层改为0层<br />         )<br />         (LM:ApplytoBlockObjects<br />             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))<br />             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))<br />            '(lambda ( obj ) (vla-put-Color obj col))           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;颜色改为Col<br />         )<br />         (LM:ApplytoBlockObjects<br />             (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))<br />             (vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))<br />            '(lambda ( obj ) (vla-put-LinetypeScale obj (getvar 'dimscale)))           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;顺便改一下线型比例<br />         )                                                               <br /> )<br />     )<br />     (princ)<br /> (entmod(entget(ssname s 0)))(princ)<br /> )<br /> (vl-load-com) (princ)

cj52000

菜卷鱼 发表于 2015-4-17 16:33

还是不行啊，改一个块颜色，其实相同的块都改了

菜卷鱼

你把颜色改成0 ，然后你就可以通过工具栏的下拉条改颜色了

cj52000

菜卷鱼 发表于 2015-4-18 08:29
你把颜色改成0 ，然后你就可以通过工具栏的下拉条改颜色了

这个我也试过，也还是不行

菜卷鱼

cj52000 发表于 2015-4-18 10:09
这个我也试过，也还是不行

我就是这样改的