改块的颜色
;;改块的颜色(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)
)
页:
[1]