[编程交流] 改变所有颜色的lisp 13

(defun c:test (/ *error* ss cnt)
 (defun *error* (msg)
   (if (not
         (member msg '("Function cancelled" "quit / exit abort"))
       )
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 (setq ss (ssget "_X")
       cnt 0)
 (repeat (sslength ss)
   (setq obj (vlax-ename->vla-object (ssname ss cnt)))
   ;;;Need to check if block is an xref or a layout and if so, ignore rest of code
   ;;;Use an if or statement or an if and statement to do this
   (if (= (vla-get-truecolor obj) colortype)
     (vla-put-truecolor obj desiredcolor)
     )
   (setq cnt (+ cnt 1))
   )
 )

(defun c:chcolor ( / process sc dc ss i ent blnlst enx )
 (vl-load-com)
 (defun process ( b / ent blnlst enx )
   (setq ent (tblobjname "BLOCK" b))
   (while (setq ent (entnext ent))
     (if (= (cdr (assoc 0 (entget ent))) "INSERT")
       (progn
         (if
           (and
             (not (vlax-property-available-p (vlax-ename->vla-object ent) 'Path))
             (not (vl-position (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
           )
           (setq blnlst (cons (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
         )
         (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
           (progn
             (setq enx (entget ent))
             (foreach c dc
               (if (not (assoc (car c) enx))
                 (setq enx (append enx (list c)))
                 (setq enx (subst c (assoc (car c) enx) enx))
               )
             )
             (if (not (assoc 62 dc))
               (setq enx (vl-remove (assoc 62 enx) enx))
             )
             (if (not (assoc 420 dc))
               (setq enx (vl-remove (assoc 420 enx) enx))
             )
             (entupd (cdr (assoc -1 (entmod enx))))
           )
         )
       )
       (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
         (progn
           (setq enx (entget ent))
           (foreach c dc
             (if (not (assoc (car c) enx))
               (setq enx (append enx (list c)))
               (setq enx (subst c (assoc (car c) enx) enx))
             )
           )
           (if (not (assoc 62 dc))
             (setq enx (vl-remove (assoc 62 enx) enx))
           )
           (if (not (assoc 420 dc))
             (setq enx (vl-remove (assoc 420 enx) enx))
           )
           (entupd (cdr (assoc -1 (entmod enx))))
         )
       )
     )
   )
   (if blnlst
     (foreach b blnlst
       (process b)
     )
   )
 )
 (alert "Choose source color to be changed...")
 (setq sc (acad_truecolordlg 256))
 (alert "Choose destination color to be changed into...")
 (setq dc (acad_truecolordlg 256))
 (if (not (equal (sssetfirst nil (ssget "_A")) '(nil nil)))
   (setq ss (ssget "_:L"))
 )
 (if ss
   (progn
     (repeat (setq i (sslength ss))
       (setq ent (ssname ss (setq i (1- i))))
       (if (= (cdr (assoc 0 (entget ent))) "INSERT")
         (progn
           (if
             (and
               (not (vlax-property-available-p (vlax-ename->vla-object ent) 'Path))
               (not (vl-position (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
             )
             (setq blnlst (cons (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
           )
           (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
             (progn
               (setq enx (entget ent))
               (foreach c dc
                 (if (not (assoc (car c) enx))
                   (setq enx (append enx (list c)))
                   (setq enx (subst c (assoc (car c) enx) enx))
                 )
               )
               (if (not (assoc 62 dc))
                 (setq enx (vl-remove (assoc 62 enx) enx))
               )
               (if (not (assoc 420 dc))
                 (setq enx (vl-remove (assoc 420 enx) enx))
               )
               (entupd (cdr (assoc -1 (entmod enx))))
             )
           )
         )
         (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
           (progn
             (setq enx (entget ent))
             (foreach c dc
               (if (not (assoc (car c) enx))
                 (setq enx (append enx (list c)))
                 (setq enx (subst c (assoc (car c) enx) enx))
               )
             )
             (if (not (assoc 62 dc))
               (setq enx (vl-remove (assoc 62 enx) enx))
             )
             (if (not (assoc 420 dc))
               (setq enx (vl-remove (assoc 420 enx) enx))
             )
             (entupd (cdr (assoc -1 (entmod enx))))
           )
         )
       )
     )
     (if blnlst
       (foreach b blnlst
         (process b)
       )
     )
   )
 )
 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
 (princ)
)

(defun c:test ( / acdoc ss) (vl-load-com)
 (setq acdoc (vla-get-activedocument (vlax-get-acad-object)))
 (if
   (ssget ":L")
   (progn
     (vlax-for obj (setq ss (vla-get-activeselectionset acdoc))
       (change2cyan obj)
     )
     (vla-delete ss)
   )
 )
 (vla-regen acdoc acAllViewports)
 (princ)
 )
(defun change2cyan (obj)
 (cond
   ((eq (vla-get-objectname obj) "AcDbBlockReference")
    (vlax-for x (vla-item (vla-get-blocks acdoc) (vla-get-name obj))
      (change2cyan x))
    )
   ((= (vla-get-color obj) 13)
    (vla-put-color obj 4)
   )
 )
)

(defun c:chcolor-blk ( / process sc dc ss n s i ent blnlst enx )
 (vl-load-com)
 (defun process ( b / ent blnlst enx )
   (setq ent (tblobjname "BLOCK" b))
   (while (setq ent (entnext ent))
     (if (= (cdr (assoc 0 (entget ent))) "INSERT")
       (progn
         (if
           (and
             (not (vlax-property-available-p (vlax-ename->vla-object ent) 'Path))
             (not (vl-position (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
           )
           (setq blnlst (cons (vla-get-effectivename (vlax-ename->vla-object ent)) blnlst))
         )
         (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
           (progn
             (setq enx (entget ent))
             (foreach c dc
               (if (not (assoc (car c) enx))
                 (setq enx (append enx (list c)))
                 (setq enx (subst c (assoc (car c) enx) enx))
               )
             )
             (if (not (assoc 62 dc))
               (setq enx (vl-remove (assoc 62 enx) enx))
             )
             (if (not (assoc 420 dc))
               (setq enx (vl-remove (assoc 420 enx) enx))
             )
             (entupd (cdr (assoc -1 (entmod enx))))
           )
         )
       )
       (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
         (progn
           (setq enx (entget ent))
           (foreach c dc
             (if (not (assoc (car c) enx))
               (setq enx (append enx (list c)))
               (setq enx (subst c (assoc (car c) enx) enx))
             )
           )
           (if (not (assoc 62 dc))
             (setq enx (vl-remove (assoc 62 enx) enx))
           )
           (if (not (assoc 420 dc))
             (setq enx (vl-remove (assoc 420 enx) enx))
           )
           (entupd (cdr (assoc -1 (entmod enx))))
         )
       )
     )
   )
   (if blnlst
     (foreach b blnlst
       (process b)
     )
   )
 )
 (alert "Choose source color to be changed...")
 (setq sc (acad_truecolordlg 256))
 (alert "Choose destination color to be changed into...")
 (setq dc (acad_truecolordlg 256))
 (alert "Pick Block Reference on unlocked layer...")
 (setq ss (ssget "_+.:E:S:L" '((0 . "INSERT"))))
 (while (or (not ss) (vlax-property-available-p (vlax-ename->vla-object (ssname ss 0)) 'Path))
   (prompt "\nMissed or picked entity not INSERT entity or picked INSERT entity belong to Xref or picked entity not on unlocked layer... Try again...")
   (setq ss (ssget "_+.:E:S:L" '((0 . "INSERT"))))
 )
 (setq n (vla-get-effectivename (vlax-ename->vla-object (ssname ss 0))))
 (if (not (equal (sssetfirst nil (ssget "_A" '((0 . "INSERT")))) '(nil nil)))
   (setq s (ssget "_:L"))
 )
 (setq ss (ssadd))
 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
   (if (= n (vla-get-effectivename (vlax-ename->vla-object e)))
     (ssadd e ss)
   )
 )
 (if ss
   (progn
     (repeat (setq i (sslength ss))
       (setq ent (ssname ss (setq i (1- i))))
       (if (vl-every '(lambda ( x ) (vl-position x (entget ent))) sc)
         (progn
           (setq enx (entget ent))
           (foreach c dc
             (if (not (assoc (car c) enx))
               (setq enx (append enx (list c)))
               (setq enx (subst c (assoc (car c) enx) enx))
             )
           )
           (if (not (assoc 62 dc))
             (setq enx (vl-remove (assoc 62 enx) enx))
           )
           (if (not (assoc 420 dc))
             (setq enx (vl-remove (assoc 420 enx) enx))
           )
           (entupd (cdr (assoc -1 (entmod enx))))
         )
       )
     )
     (process n)
   )
 )
 (prompt "\nProcessed : ") (princ (sslength ss)) (prompt (strcat " block references with name of picked reference : "" n ""\n"))
 (vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
 (textscr)
 (princ)
)