[求助]改块颜色。

userzhl

(defun c:blk_col( / blk blkref blocks doc ent name ss n clo)
 (vl-load-com)
  (princ "\n选要改颜色的块: ")
(setq ss (ssget '((0 . "INSERT")))
      n  (sslength ss)
)
  (while (and (setq BLK     (ssname ss (setq n (1- n))))
   (setq BLKREF  (vlax-ename->vla-object BLK))
   (not(and(/= (vla-get-objectname BLKREF) "AcDbBlockReference")
       (princ"\n不是块:"))
    )
       (setq clo (acad_colordlg 7))

   (setq name(vla-get-name BLKREF))
      )
    (progn
          (command"undo""group")
          (setq DOC     (vla-get-activedocument (vlax-get-acad-object))
                BLOCKS  (vla-get-blocks doc)
         blk     (vla-item BLOCKS name)
          )
           (vlax-for ENT blk
             (vla-put-layer ent "图块")
             (vla-put-color ent clo)
           )
        (vla-regen doc acActiveViewport)
        (vlax-release-object blk)
        (vlax-release-object BLOCKS)
        (vlax-release-object DOC)
        (command"undo""end")
       
     )
  )
  (princ"\nUndo后请regen.")
(princ))

这个程序只能单选，而且需要选色——可不可以改成这样：

不用多次选色(即：可同时选择若干个块，无论是多重块嵌套块还是属性块)，颜色自动改为8号色(不需选色)，并把其图层(块内的所有图元)自动归到"图块"层。

HuaiYu

已改写成如下，请验收：

(Defun c:tt2 (/ ss color layer i *AcadDocument* blocks vn)
  ;; 子程序  .
  (Defun sub_Fun (vn)
    (vla-put-color vn color)
    (vla-put-layer vn layer)
    (vlax-for ent (vla-item blocks (vla-get-name vn))
      (vla-put-color ent color)
      (vla-put-layer ent layer)
      (if (= (vla-get-objectname ent) "AcDbBlockReference")
 (sub_Fun ent)
      )
    )
  )
  ;; 程序开始 .
  (vl-load-com)
  (princ "\n选要改颜色的块: ")
  (setq ss (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))
  (cond ((or (vl-catch-all-error-p ss) (null ss)) (vl-exit-with-value 0)))
  ;; 设定这个要改的 color=8,layer="图块"  (假设 "图块"层一定存在) .
  (setq color 8
 layer "图块"
  )
  (setq i        0
 *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))
 blocks        (vla-get-blocks *AcadDocument*)
  )
  (repeat (sslength ss)
    (setq vn (vlax-ename->vla-object (ssname ss i))
   i  (1+ i)
    )
    ;; 防止出错 .
    (sub_Fun vn)
  )
  (prin1)
)

userzhl

非常感谢！

HuaiYu

根据斑主的指示，已将 Attribute 改好，但标注的尺寸是改的不是很好的...

我看了一下，觉得应该要将 dimstyle 中的 textColor ExtensionLineColor DimensionLineColor 设成 0即 ByBlock才行的...

还请版主明示......

(Defun c:tt2 (/ ss color layer i *AcadDocument* blocks vn)
  ;; 子程序  .
  (Defun sub_Fun (vn / atts)
    (vla-put-color vn color)
    (vla-put-layer vn layer)
    (cond
      ((and (= (vla-get-objectname vn) "AcDbBlockReference") (= (vla-get-hasAttributes vn) :vlax-true))
       (setq atts (vlax-safeArray->list (vlax-variant-value (vla-getAttributes vn))))
       (foreach att atts (vla-put-color att color) (vla-put-layer att layer))
      )
    )
    (vlax-for ent (vla-item blocks (vla-get-name vn))
      (vla-put-color ent color)
      (vla-put-layer ent layer)
      (cond ((wcmatch (vla-get-objectName ent) "AcDb*Dimension")
      (vla-put-DimensionLineColor ent color)
      (vla-put-textColor ent color)
      (vla-put-ExtensionLineColor ent color)
     )
      )
      (if (= (vla-get-objectname ent) "AcDbBlockReference")
 (sub_Fun ent)
      )
    )
  )
  ;; 程序开始 .
  (vl-load-com)
  (princ "\n选要改颜色的块: ")
  (setq ss (vl-catch-all-apply 'ssget '(((0 . "INSERT")))))
  (cond ((or (vl-catch-all-error-p ss) (null ss)) (vl-exit-with-value 0)))
  ;; 设定这个要改的 color=8,layer="图块"  (假设 "图块"层一定存在) .
  (setq color 8
 layer "图块"
  )
  (setq i        0
 *AcadDocument* (vla-get-activeDocument (vlax-get-acad-object))
 blocks        (vla-get-blocks *AcadDocument*)
  )
  (repeat (sslength ss)
    (setq vn (vlax-ename->vla-object (ssname ss i))
   i  (1+ i)
    )
    ;; 防止出错 .
    (sub_Fun vn)
  )
  (prin1)
)

 

龙龙仔

;;实在还有一些改进的地方,附图供测试
;;我U盘上有ch_color.vlx程序,是改全图顏色比较效果看看

zhangrunze

龙龙仔 发表于 2006-9-7 09:21
;;实在还有一些改进的地方,附图供测试;;我U盘上有ch_color.vlx程序,是改全图顏色比较效果看看

感谢分享~
ch_color.vlx可以分享下吗？