[求助]求图块改颜色的程序

54256

别人做过来的块,很不规范,块里的对象颜色没有随层,块也没有定义到0层,尤其是块里套块的情况

现在求一下这样的小程序:

1.保留目前块所在的层,但是块的定义是在0层定义的

2.块中所有对象的颜色都随层

3.块里套块情况也要处理

总之,打个比方,经过处理后,一个块还是保留它目前的层,比如"家具层",这个块的颜色已经都变成"家具层",的颜色8

我觉得这样的程序挺实用的,不知道说清楚没有,谢谢

caoyin

是 vlax-ename->vla-object 吧，
(vl-load-com)

;;网站的网页程序的关系，直接复制代码有问题，重发一下
;;-------------------------------------------------------------------
(defun c:ChColor (/ SS BLKS I BNLst)
  (princ "\n选择要修改颜色的对象: ")
  (if (and (setq SS (ssget))
           (or $ChColor$ (setq $ChColor$ 7))
           (setq $ChColor$ (acad_colordlg $ChColor$))
      )
    (progn
      (setq BLKS  (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
      (defun ChColor (OBJ / oName BlkName)
        (setq oName (vla-get-ObjectName OBJ))
        (cond
          ((wcmatch oName "*Dimension,AcDbLeader,AcDbFcf")
           (vla-put-DimensionLineColor OBJ $ChColor$)
           (if (wcmatch oName "*Dimension")
             (progn
               (vla-put-ExtensionLineColor OBJ $ChColor$)
               (if (setq BlkName (assoc 2 (entget (vlax-vla-object->ename OBJ))))
                 (vlax-for OBJ (vla-item Blks (cdr BlkName))
                   (vla-put-color OBJ $ChColor$)
                 )
               )
             )
           )
           (if (wcmatch oName "*Dimension,AcDbFcf")
             (vla-put-TextColor OBJ $ChColor$)
           )
          )
          ((= oName "AcDbBlockReference")
           (setq BlkName (vla-get-name OBJ))
           (if (not (member BlkName BNLst))
             (progn
               (setq BNLst (cons BlkName BNLst))
               (vlax-for X (vla-item Blks BlkName)
                 (ChColor X)
               )
             )
           )
           (if (= (vla-get-HasAttributes OBJ) :vlax-true)
             (foreach X (vlax-invoke OBJ 'getattributes)
               (vla-put-color X $ChColor$)
             )
           )
          )
        )
        (vla-put-color obj $ChColor$)
      )
      (repeat (setq I (sslength SS))
        (setq OBJ (vlax-ename->vla-object (ssname SS (setq I (1- I)))))
        (ChColor OBJ)
      )
    )
  )
  (princ)
)

刘炎华

请问:为追求速度,不要弹出选颜色的对话框,要改哪里呢?
例如一个命令对应一种颜色)
(defun c:V1 ()   (command "change" (ssget) "" "p" "c" "1" "")(princ))
(defun c:V2 ()   (command "change" (ssget) "" "p" "c" "2" "")(princ))

caoyin

参考29楼的程序，自己修改一下

http://www.mjtd.com/bbs/dispbbs.asp?boardid=3&replyid=118821&id=72404&page=1&skin=0&landlord=0&Star=3

54256

楼上的程序运行中出错,不知道为什么望赐教

caoyin

可能是未加载函数

(setq SS (lt:ssget '("\n选择要修改颜色的对象: ")))
->

(setq SS (ssget))

caoyin

;;改块的

(defun c:ChBlkColor (/ ChBlkColor SS blks I Obj BnLst)
  (defun ChBlkColor (Blks Obj Color / BlkName oName)
    (if (and (= (vla-get-ObjectName obj) "AcDbBlockReference")
             (= (vla-get-HasAttributes obj) :vlax-true)
        )
      (foreach x (vlax-invoke obj 'getattributes)
        (vla-put-color x Color)
      )
    )
    (setq BlkName (vla-get-name obj))
    (if (not (member BlkName bnlst))
      (progn
        (setq bnlst (cons BlkName BnLst))
        (vlax-for X (vla-item Blks BlkName)
          (setq oName (vla-get-ObjectName X))
          (cond ((wcmatch oName "*Dimension,AcDbLeader,AcDbFcf")
                 (vla-put-DimensionLineColor X Color)
                 (if (wcmatch oName "*Dimension")
                   (progn
                     (vla-put-ExtensionLineColor X Color)
                     (if (setq BlkName (assoc 2 (entget (vlax-vla-object->ename X))))
                       (vlax-for X (vla-item Blks (cdr BlkName))
                         (vla-put-color X Color)
                       )
                     )
                   )
                 )
                 (if (wcmatch oName "*Dimension,AcDbFcf")
                   (vla-put-TextColor X Color)
                 )
                )
                ((= oName "AcDbBlockReference")
                 (ChBlkColor Blks X Color)
                )
          )
          (vla-put-color X Color)
        )
      )
    )
    (vla-UpDate obj)
  )
  (if (and (setq ss (ssget '((0 . "insert"))))
           (or $ChBlkColor$ (setq $ChBlkColor$ 7))
           (setq $ChBlkColor$ (acad_colordlg $ChBlkColor$))
      )
    (progn
      (setq blks (vla-get-blocks (vla-get-activedocument (vlax-get-acad-object))))
      (repeat (setq i (sslength ss))
        (setq obj (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
        (ChBlkColor Blks Obj $ChBlkColor$)
      )
    )
  )
  (princ)
)

caoyin

本帖7 、8楼没用任何自定义函数啊！！

怪事！！为什么我用没问题？？(问题好像有一个，就是在 UpDate，空了修改)