请问有没有改变多个图层中所有块的颜色的工具
现在想把原始图做为底图，要把图中的所有东西都变成8号灰色，但图中块啊什么的太多，很多改不颜色，要一个一个的改很麻烦，想问问有没有啥工具能一次改，还能把这些东西都集中到一个图层上去的工具呢？ (defun c:tt(/ doc ss obj en subobj color ent sk_lay)(vl-load-com)
(setq sk_lay(sk_getdcl))
(setq color (acad_colordlg 8))
(if(and (or sk_lay color)
(setq ss(ssget))
)
(progn
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
;(setq sk_lay "0")
(while(setq ent(ssname ss 0))
(setq obj (vlax-ename->vla-object ent))
(and sk_lay(vla-put-layer (vlax-ename->vla-object ent) sk_lay))
(and color(vla-put-color (vlax-ename->vla-object ent) Color))
(defun sk_block_col(obj /)
(vlax-for SubObj
(vla-item (vla-get-blocks doc)
(vla-get-name obj) ;获得块名
) ;获取当前文档中的所有块，按照名字从中找到操作者选择的块，返回块中所有对象的集合
(and sk_lay(vla-put-layer SubObj sk_lay))
(if (= (vla-get-ObjectName SubObj) "AcDbBlockReference")
(sk_block_col SubObj)
(progn
(if (= (vla-get-ObjectName SubObj) "AcDbAttributeDefinition")
(sk_att_lay_col ENT (vla-get-TagStringSubObj) sk_layColor)
(and Color(vla-put-color SubObj Color))
)
)
) ;obj依次为块内每一个图元的对象
) ;调用自己，递归，遍历引用中的每层引用
)
(if (= (vla-get-ObjectName obj) "AcDbBlockReference") (progn (sk_block_col obj)))
(setq ss (ssdel ent ss))
)
(vla-regen doc 1)
(vlax-release-object obj)
(vlax-release-object doc)
)
)
(princ)
)
(defun sk_getdcl(/ lay_lst sk_lay dcl f s sk_lay_index DCL_ID )
(vlax-map-collection (vla-get-Layers (vla-get-activedocument (vlax-get-acad-object))) '(lambda (x) (setq lay_lst (cons (vla-get-name x) lay_lst))))
(setq lay_lst (reverse(mapcar 'vl-princ-to-string lay_lst)))
(setq DCL (vl-filename-mktemp nil nil ".Lsp"))
(setq f (open dcl "w"))
(foreach s '("ch_block_color:dialog {"
" label = \"参数设置\" ;"
" :boxed_row {"
" label = \"设置\" ;"
" :list_box {"
" fixed_height = true ;"
" fixed_width = true ;"
" height = 24 ;"
" label = \"图层选择\" ;"
" width = 30 ;"
" key = sk_lay ;"
" }"
" }"
"ok_cancel;"
"}"
)
(write-line s f)
)
(close f)
(setq DCL_ID (load_dialog DCL))
(vl-file-delete dcl)
(new_dialog "ch_block_color" DCL_ID)
(start_list "sk_lay")
(mapcar 'add_list lay_lst)
(end_list)
(action_tile "accept" "(setq sk_lay_index(get_tile \"sk_lay\"))(done_dialog 1) ")
(action_tile "cancel" "(done_dialog)")
(start_dialog )
(unload_dialog DCL_ID)
(if sk_lay_index
(setq sk_lay (nth (atoi sk_lay_index) lay_lst)) nil)
sk_lay
)
;;;日期：zml84 于 2010-05-08 *
;;;日期：modfiy by edata@2014-6-12 *
;;;add layer
(defun sk_att_lay_col (EN ATTNAME sk_lay Color / RETURN E TEST ENT)
(setq E EN
RETURN NIL
TEST t
)
(while (and TEST (setq E (entnext E)))
(setq ENT (entget E))
(cond ((not (= (cdr (assoc 0 ENT)) "ATTRIB")) (setq TEST NIL))
((= "SEQEND" (cdr (assoc 0 ENT))) (setq TEST NIL))
((= (cdr (assoc 2 ENT)) ATTNAME)
(and sk_lay(setq ENT (subst(cons 8 sk_lay)(assoc 8 ENT) ENT)))
(if (and Color(assoc 62 ENT))
(setq ENT (subst(cons 62 Color)(assoc 62 ENT) ENT))
(setq ENT (cons (cons 62 Color) ENT))
)
(entmod ENT)
(entupd EN)
(setq RETURN t)
)
)
)
RETURN
) 有点高端了，慢慢看怎么用 这代码如何用呢，还真不知道 不错，会用了，谢谢，很好用 整理图纸的时候用的上 可以用吗？我想找一个可以吧嵌套块全部批量改0层的lsp，不懂论坛有没有，没怎么搜到 edata 发表于 2014-6-12 18:19 static/image/common/back.gif
请问下大神，能不能做到不要对话框呢？（有对话框感觉点来点去，速度就慢了）图层直接弄到2图层，颜色250，加个DASH虚线进去，线型比例是15，要怎么做呢？ 如果没有线型则需要加载，我只改了自动生成dashed（acadiso.lin）.
需要其他线型需要自行加载。
(defun c:tt(/ doc ss obj en subobj color ent sk_lay sk_ltype sk_ltscale)
(vl-load-com)
(setq sk_lay "2")
(setq color 250)
(setq sk_ltype "dashed")
(setq sk_ltscale 15)
(if(and (or (and sk_lay (tblobjname "layer" sk_lay))color)
(setq ss(ssget))
)
(progn
(or (tblobjname "layer" sk_lay) (setq sk_lay nil))
(or (tblobjname "ltype" sk_ltype)
(entmake
'((0 . "LTYPE")
(5 . "23D")
(100 . "AcDbSymbolTableRecord")
(100 . "AcDbLinetypeTableRecord")
(2 . "DASHED")
(70 . 0)
(3 . "Dashed __ __ __ __ __ __ __ __ __ __ __ __ __ _")
(72 . 65)
(73 . 2)
(40 . 19.05)
(49 . 12.7)
(74 . 0)
(49 . -6.35)
(74 . 0)
)
))
(or (tblobjname "ltype" sk_ltype) (setq sk_ltype nil))
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
;(setq sk_lay "0")
(while(setq ent(ssname ss 0))
(setq obj (vlax-ename->vla-object ent))
(and sk_lay(vla-put-layer (vlax-ename->vla-object ent) sk_lay))
(and color(vla-put-color (vlax-ename->vla-object ent) Color))
(and sk_ltype(vla-put-linetype (vlax-ename->vla-object ent) sk_ltype))
(and sk_ltscale(vla-put-linetypescale (vlax-ename->vla-object ent) sk_ltscale))
(defun sk_block_col(obj /)
(vlax-for SubObj
(vla-item (vla-get-blocks doc)
(vla-get-name obj) ;获得块名
) ;获取当前文档中的所有块，按照名字从中找到操作者选择的块，返回块中所有对象的集合
(and sk_lay(vla-put-layer SubObj sk_lay))
(and sk_ltype(vla-put-linetype SubObj sk_ltype))
(and sk_ltscale(vla-put-linetypescale SubObj sk_ltscale))
(if (= (vla-get-ObjectName SubObj) "AcDbBlockReference")
(sk_block_col SubObj)
(progn
(if (= (vla-get-ObjectName SubObj) "AcDbAttributeDefinition")
(sk_att_lay_col ENT (vla-get-TagStringSubObj) sk_layColor)
(and Color(vla-put-color SubObj Color))
)
)
) ;obj依次为块内每一个图元的对象
) ;调用自己，递归，遍历引用中的每层引用
)
(if (= (vla-get-ObjectName obj) "AcDbBlockReference") (progn (sk_block_col obj)))
(setq ss (ssdel ent ss))
)
(vla-regen doc 1)
(vlax-release-object obj)
(vlax-release-object doc)
)
)
(princ)
)
;;;日期：zml84 于 2010-05-08 *
;;;日期：modfiy by edata@2014-6-12 *
;;;add layer
(defun sk_att_lay_col (EN ATTNAME sk_lay Color / RETURN E TEST ENT)
(setq E EN
RETURN NIL
TEST t
)
(while (and TEST (setq E (entnext E)))
(setq ENT (entget E))
(cond ((not (= (cdr (assoc 0 ENT)) "ATTRIB")) (setq TEST NIL))
((= "SEQEND" (cdr (assoc 0 ENT))) (setq TEST NIL))
((= (cdr (assoc 2 ENT)) ATTNAME)
(and sk_lay(setq ENT (subst(cons 8 sk_lay)(assoc 8 ENT) ENT)))
(if (and Color(assoc 62 ENT))
(setq ENT (subst(cons 62 Color)(assoc 62 ENT) ENT))
(setq ENT (cons (cons 62 Color) ENT))
)
(entmod ENT)
(entupd EN)
(setq RETURN t)
)
)
)
RETURN
)
edata 发表于 2015-7-29 15:45 static/image/common/back.gif
如果没有线型则需要加载，我只改了自动生成dashed（acadiso.lin）.
需要其他线型需要自行加载。
大师，想把原始图做为底图，一般都是复制一份在旁边的，刚才试了下你这个，已经接近完美了，但原图的图块也跟着变成了250色，能否把选中的块也改名（例如加 _222防止跟其他块重名）主要是不想变的同名图块也跟着变色了。。，可以再修改一下的话，就完美了
页:
[1]
2