大家帮我看下这个改图块颜色程序如何完善下！
大家好：现有一个改图块颜色的程序，因为工作中会插入很多相同的块，我目的是想单独改某一个块的颜色，而这个程序是你点个某个块后，图档中所有的相同块颜色都变了，请大家帮完善一下，谢谢各位！
(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 "\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)
)
cj52000 发表于 2015-4-17 18:03
还是不行啊，改一个块颜色，其实相同的块都改了
同样的需求 请问解决问题了吗 alexmai 发表于 2021-9-17 23:46
块颜色改为byblock
不太懂呢 怎么操作呢有完整代码吗 依然小小鸟 发表于 2021-9-9 14:28
同样的需求 请问解决问题了吗
块颜色改为byblock 各位老大帮忙看看啊 其实是不用编程的，利用ACAD的基本知识就可以达到目的。
ACAD的0层实际上是透明的，所以又叫透明层。
做法：1、将图元绘制在0层，颜色随层，然后定义图块。
2、在不同的图层中插入图块，就会形成颜色与图层颜色相同的图块。 (defun LM:ApplytoBlockObjects ( blks name func / result )
(setq func (eval func))
(if (not (vl-catch-all-error-p (setq def (vl-catch-all-apply 'vla-item (list blks name)))))
(vlax-for obj def (setq result (cons (func obj) result)))
)
(reverse result)
)
(defun c:bco ( / s col)
(if (= ocol nil)(setq ocol 0))
(princ "\nSelect Block: ")
(if (setq s (ssget "_+.:E:S" '((0 . "INSERT"))))
(progn
(mapcar 'princ (list "\nNumber of color:[<" ocol ">]"))
(prin1)
(setq col(getint ))
(if (/= col nil)(setq ocol col)(setq col ocol))
(LM:ApplytoBlockObjects
(vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
(vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
'(lambda ( obj ) (vla-put-layer obj "0")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;图层改为0层
)
(LM:ApplytoBlockObjects
(vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
(vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
'(lambda ( obj ) (vla-put-Color obj col)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;颜色改为Col
)
(LM:ApplytoBlockObjects
(vla-get-blocks (vla-get-activedocument (vlax-get-acad-object)))
(vla-get-effectivename (vlax-ename->vla-object (ssname s 0)))
'(lambda ( obj ) (vla-put-LinetypeScale obj (getvar 'dimscale))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;顺便改一下线型比例
)
)
)
(princ)
(entmod(entget(ssname s 0)))(princ)
)
(vl-load-com) (princ)
菜卷鱼 发表于 2015-4-17 16:33 static/image/common/back.gif
还是不行啊，改一个块颜色，其实相同的块都改了 你把颜色改成0 ，然后你就可以通过工具栏的下拉条改颜色了 菜卷鱼 发表于 2015-4-18 08:29 static/image/common/back.gif
你把颜色改成0 ，然后你就可以通过工具栏的下拉条改颜色了
这个我也试过，也还是不行 cj52000 发表于 2015-4-18 10:09 static/image/common/back.gif
这个我也试过，也还是不行
我就是这样改的
页:
[1]
2