[求助]改块颜色。
(defun c:blk_col( / blk blkref blocks doc ent name ss n clo)<BR> (vl-load-com)<BR> (princ "\n选要改颜色的块: ")<BR>(setq ss (ssget '((0 . "INSERT")))<BR> n (sslength ss)<BR>)<BR> (while (and (setq BLK (ssname ss (setq n (1- n))))<BR> (setq BLKREF (vlax-ename->vla-object BLK))<BR> (not(and(/= (vla-get-objectname BLKREF) "AcDbBlockReference")<BR> (princ"\n不是块:"))<BR> )<BR> (setq clo (acad_colordlg 7))<P> (setq name(vla-get-name BLKREF))<BR> )<BR> (progn<BR> (command"undo""group")<BR> (setq DOC (vla-get-activedocument (vlax-get-acad-object))<BR> BLOCKS (vla-get-blocks doc)<BR> blk (vla-item BLOCKS name)<BR> )<BR> (vlax-for ENT blk<BR> (vla-put-layer ent "图块")<BR> (vla-put-color ent clo)<BR> )<BR> (vla-regen doc acActiveViewport)<BR> (vlax-release-object blk)<BR> (vlax-release-object BLOCKS)<BR> (vlax-release-object DOC)<BR> (command"undo""end")<BR> <BR> )<BR> )<BR> (princ"\nUndo后请regen.")<BR>(princ))</P>
<P>这个程序只能单选，而且需要选色——可不可以改成这样：</P>
<P>不用多次选色(即：可同时选择若干个块，无论是多重块嵌套块还是属性块)，颜色自动改为8号色(不需选色)，并把其图层(块内的所有图元)自动归到"图块"层。</P> <P>已改写成如下，请验收：</P>
<P>(Defun c:tt2 (/ ss color layer i *AcadDocument* blocks vn)<BR> ;; 子程序 .<BR> (Defun sub_Fun (vn)<BR> (vla-put-color vn color)<BR> (vla-put-layer vn layer)<BR> (vlax-for ent (vla-item blocks (vla-get-name vn))<BR> (vla-put-color ent color)<BR> (vla-put-layer ent layer)<BR> (if (= (vla-get-objectname ent) "AcDbBlockReference")<BR> (sub_Fun ent)<BR> )<BR> )<BR> )<BR> ;; 程序开始 .<BR> (vl-load-com)<BR> (princ "\n选要改颜色的块: ")<BR> (setq ss (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))<BR> (cond ((or (vl-catch-all-error-p ss) (null ss)) (vl-exit-with-value 0)))<BR> ;; 设定这个要改的 color=8,layer="图块" (假设 "图块"层一定存在) .<BR> (setq color 8<BR> layer "图块"<BR> )<BR> (setq i 0<BR> *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))<BR> blocks (vla-get-blocks *AcadDocument*)<BR> )<BR> (repeat (sslength ss)<BR> (setq vn (vlax-ename->vla-object (ssname ss i))<BR> i (1+ i)<BR> )<BR> ;; 防止出错 .<BR> (sub_Fun vn)<BR> )<BR> (prin1)<BR>)<BR></P> 非常感谢！ <P>根据斑主的指示，已将 Attribute 改好，但标注的尺寸是改的不是很好的...</P>
<P>我看了一下，觉得应该要将 dimstyle 中的 textColor ExtensionLineColor DimensionLineColor 设成 0即 ByBlock才行的...</P>
<P>还请版主明示......</P>
<P>(Defun c:tt2 (/ ss color layer i *AcadDocument* blocks vn)<BR> ;; 子程序 .<BR> (Defun sub_Fun (vn / atts)<BR> (vla-put-color vn color)<BR> (vla-put-layer vn layer)<BR> (cond<BR> ((and (= (vla-get-objectname vn) "AcDbBlockReference") (= (vla-get-hasAttributes vn) :vlax-true))<BR> (setq atts (vlax-safeArray->list (vlax-variant-value (vla-getAttributes vn))))<BR> (foreach att atts (vla-put-color att color) (vla-put-layer att layer))<BR> )<BR> )<BR> (vlax-for ent (vla-item blocks (vla-get-name vn))<BR> (vla-put-color ent color)<BR> (vla-put-layer ent layer)<BR> (cond ((wcmatch (vla-get-objectName ent) "AcDb*Dimension")<BR> (vla-put-DimensionLineColor ent color)<BR> (vla-put-textColor ent color)<BR> (vla-put-ExtensionLineColor ent color)<BR> )<BR> )<BR> (if (= (vla-get-objectname ent) "AcDbBlockReference")<BR> (sub_Fun ent)<BR> )<BR> )<BR> )<BR> ;; 程序开始 .<BR> (vl-load-com)<BR> (princ "\n选要改颜色的块: ")<BR> (setq ss (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))<BR> (cond ((or (vl-catch-all-error-p ss) (null ss)) (vl-exit-with-value 0)))<BR> ;; 设定这个要改的 color=8,layer="图块" (假设 "图块"层一定存在) .<BR> (setq color 8<BR> layer "图块"<BR> )<BR> (setq i 0<BR> *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))<BR> blocks (vla-get-blocks *AcadDocument*)<BR> )<BR> (repeat (sslength ss)<BR> (setq vn (vlax-ename->vla-object (ssname ss i))<BR> i (1+ i)<BR> )<BR> ;; 防止出错 .<BR> (sub_Fun vn)<BR> )<BR> (prin1)<BR>)</P>
<P> </P> <P>;;实在还有一些改进的地方,附图供测试<BR>;;我U盘上有ch_color.vlx程序,是改全图顏色比较效果看看</P>
<P></P> 龙龙仔 发表于 2006-9-7 09:21
;;实在还有一些改进的地方,附图供测试;;我U盘上有ch_color.vlx程序,是改全图顏色比较效果看看
感谢分享~
ch_color.vlx可以分享下吗？
页:
[1]