[编程交流] 块颜色

(defun c:test (/ attribute b blk color i lst name obj sn ss do)
;;;;;            Tharwat 01. June. 2012                 ;;;;;
;;;;;              This peice of code to change all           ;;;;;
;;;;;  selected objects (Blocks / Attribted Block / Objects)   ;;;;;
 (if (not acdoc)
   (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
 )
 (if (and (setq color (acad_colordlg 7 t))
          (setq ss (ssget "_:L"))
     )
   (progn
     (vla-startundomark acdoc)
     (repeat (setq i (sslength ss))
       (setq obj (vlax-ename->vla-object
                   (setq sn (ssname ss (setq i (1- i))))
                 )
       )
       (cond
         ((eq (cdr (assoc 66 (entget sn))) 1)
          (progn
            (setq do t)
            (vlax-for block (setq b (vla-item (vla-get-blocks acdoc)
                                              (cdr (assoc 2 (entget sn)))
                                    )
                            )
              (vlax-for x b (vla-put-color x color))
            )
            (foreach attribute (vlax-invoke obj 'Getattributes)
              (vla-put-color attribute color)
            )
          )
         )
         ((and (eq (cdr (assoc 0 (entget sn))) "INSERT")
               (not (member (cdr (assoc 2 (entget sn))) lst))
          )
          (progn
            (setq lst (cons (cdr (assoc 2 (entget sn))) lst))
            (vlax-for block
                      (setq blk (vla-item (vla-get-blocks acdoc)
                                          (cdr (assoc 2 (entget sn)))
                                )
                      )
              (if (eq :vlax-false (vla-get-isXref blk))
                (vlax-for x blk
                  (if
                    (not
                      (eq "AcDbBlockReference" (vla-get-objectname x))
                    )
                     (vla-put-color x color)
                  )
                )
              )
            )
          )
         )
         (t (vla-put-color obj color))
       )
     )
     (if do
       (vl-cmdf "_.attsync"
                "_name"
                (cdr (assoc 2 (entget sn)))
                ""
       )
     )
     (vla-regen acdoc acAllViewports)
     (vla-endundomark acdoc)
   )
   (princ)
 )
 (princ "\n Written by Tharwat Al Shoufi ")
 (princ)
)

5