改块的颜色

admin

;;改块的颜色

(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)
)