Layer color bypick lisp to work on dimensions?

[DC-MWA]

Hello,

I have a very cool lisp that we use to allow layer color control bypick in model or viewports.

It fails on dimensions. I'm hoping someone can modify the code to work with dimensions.

I have attached the file.

Thank you in advance for your time.

-dc

[Kent1Cooper]

Define "fails."  I assume it doesn't assign the chosen color to the Dimension's Layer, but is there anything else?  For example, does it assign that color to some other Layer?  Does it assign some color other than the chosen one to the Dimension's Layer?  Etc.

[I have a feeling it may be at least related somehow to the fact that the color assigned to parts nested in Dimensions is ByBlock, rather than ByLayer, but that may be a red herring.]

[DC-MWA]

It acts like it has completed the task, but does nothing.

Command line:

Layer Modified: < A-ANNO-SLOP-EXISTING >
Done!

[paullimapa · Accepted solution]

try this fix and I'm calling function lcp

;; lcp layer color bypick
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/layer-color-bypick-lisp-to-work-on-dimensions/m-p/11657286#M441529
(defun c:lcp (/ _get LM:True->RGB LM:str->lst e lay col sp colType lstCommands)
  ;; RJP » 2019-03-28
  ;; CodeDing 09-03-20 revised to use true color too.
  (defun _get (e)
;;; remove this section so function won't fail when object is on Layer 0
;;;    (car (vl-remove-if
;;;           '(lambda (x) (= "0" (cdr (assoc 8 (entget x)))))
;;;           (append (list (car e)) (cadddr e))
;;;         );vl-remove-if
;;;    );car
   (car (append (list (car e)) (cadddr e)))
  )
  (defun LM:True->RGB ( c )
    (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(8 16 24))
  )
  (defun LM:str->lst ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos) (LM:str->lst (substr str (+ pos 1 (strlen del))) del))
        (list str)
    )
  )
  (if (and (setq e (nentsel "\nObject on Layer to assign color to: "))
           (setq lay (cdr (assoc 8 (entget (setq e (_get e))))))
;;; remove this to avoid checking objects like dimensions that don't have a 410 group
;;;          (setq sp (cdr (assoc 410 (entget e))))
           (setq col (reverse (acad_truecolordlg (assoc 62 (tblsearch "layer" lay)))))
           (cond
             ((= 62 (caar col))
               (setq colType ".")
               (setq col (cdar col))
               (setq lstCommands (list "c" col lay ""))
             )
             ((= 420 (caar col))
               (setq colType "t")
               (setq col
                 (substr
                   (setq str
                     (apply 'strcat
                       (mapcar '(lambda (c) (strcat (itoa c) ","))
                               (LM:True->RGB (cdar col))
                       );mapcar
                     );apply
                   );setq
                   1
                   (1- (strlen str))
                 );substr
               );setq
               (setq lstCommands (list "c" colType col lay ""))
             )
             ((= 430 (caar col))
               (setq colType "co")
               (setq col (LM:str->lst (cdar col) "$"))
               (setq lstCommands (list "c" colType (car col) (cadr col) lay ""))
             )
           );cond
      );and
    (progn
;;; add this section to check model or paper vs floating vp
     (cond
      ((equal (getvar"ctab")"Model")(setq sp 0))
      ((and (zerop(getvar"tilemode"))(= 1 (getvar"cvport")))(setq sp 0))
      (t(setq sp 1))
     )
;;; add this section to check model or paper vs floating vp
    
    (if ;	(= sp (getvar 'ctab))
      (zerop sp) ; chks space
       ;; Model or paperspace
      (apply 'command (cons "-layer" lstCommands))
     ;; Floating vport
      (apply 'command-s (append '("vplayer") lstCommands '("")))
    );if
    (princ (strcat "\nLayer Modified: < " lay " >"))
   ) ; progn
    (princ (strcat "\nFunction Cancelled."))
  );if
(princ)
) ;defun

[DC-MWA]

With only brief testing, this seems to be the answer.

thank you.

[paullimapa]

glad that worked out for you cheers!!!

[Kent1Cooper]

---

@paullimapa wrote:

....

...
  (defun _get (e)
;;; remove ....
   (car (append (list (car e)) (cadddr e)))
  )
....

---

So, in other words, take the first item from a list that is made up of the first item of the argument and some other stuff....  Isn't that the same as simply taking the first item of the argument, that is, plain old (car e)?  And since it is used only once anyway, couldn't you eliminate the (_get) function altogether, and change this line:

           (setq lay (cdr (assoc 8 (entget (setq e (_get e))))))

to this?

           (setq lay (cdr (assoc 8 (entget (setq e (car e))))))

[paullimapa]

yes, good catch. if there's no need to chk for objects selected that may be on layer 0 then you don't need the _get function or change this function:

(setq e (nentsel "\nObject on Layer to assign color to: ")

to:

(ssget "_+.:E:S" '((8 . "~0")))

also i just thought of instead of this cond code to check for being inside pspace vport:

     (cond
      ((equal (getvar"ctab")"Model")(setq sp 0))
      ((and (zerop(getvar"tilemode"))(= 1 (getvar"cvport")))(setq sp 0))
      (t(setq sp 1))
     )

it could be as simple as this one liner:

    (if 
;;; add this to check model or paper vs floating vp
      (< (getvar"cvport")3) 
       ;; Model or paperspace
      (apply 'command (cons "_.-Layer" lstCommands))
     ;; Floating vport
      (apply 'command-s (append '("_.Vplayer") lstCommands '("")))
    );if