Prefix for layers LISP tweak

[AlexODCM]

Hi,

 

We have a  LISP at work with the option to give a prefix to the layers/objects selected.

But since a while this command does not take over the truecolor values of the previous layer, turns layers back to 252 color.

Is there a line that needs altering for making this work.

thanks in advance!

 

(defun c:vv ()
(setq ss nil)
(setvar "cmdecho" 0)
(setq sub (getstring "\n Give prefix to layername: "))
(setq ss (ssget))

(if (= ss nil)
    (princ "\nNo elements selected")
        (progn
        (setq tot (sslength ss))
        (setq aant 0)
        (while (< aant tot)
               (setq ent (entget (ssname ss aant))
                          oldla (cdr (assoc 8 ent))
                  gelay (tblsearch "layer" oldla)
                              colay (cdr (assoc 62 gelay))
                              ltlay (cdr (assoc 6 gelay))
                    newl (strcat sub "-" oldla) 
                              name (ssname ss aant)
                )
            (command "layer" "m" newl "c" colay "" "l" ltlay "" "")
            (command "chprop" name "" "la" newl "")
            (princ "\nElements coverted to new layer")
            (setq aant (1+ aant))
            );end while
        );end progn
);end if
(setq ss nil)
(setvar "cmdecho" 1)
(princ)
);end defun c:vv

[mhupp]

Seems dxf codes only store the 256 color code. So when making the layer it is set to that color.  Found this on making a layer but don't know how you can pull the RGB numbers.

https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7902145/highlight/true#M367270

 

This should be faster and allow you to select multiple entity's that are on different layers at once.

(defun c:vv (/ ss ss1 sub tot aant layname laylst gelay colay ltlay newl name)
  (setvar 'cmdecho 0)
  (setq oldlayer (getvar 'clayer))
  (setq sub (getstring "\n Give prefix to layername: "))
  (setq ss (ssget "_:L"))
  (if (= ss nil)
    (princ "\nNo elements selected")
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      (if (not (vl-position (setq layname (cdr (assoc 8 (entget e)))) laylst))
        (setq laylst (cons layname laylst))
      )
    )
  )
  (if (not (= laylst nil))
    (foreach lay laylst
      (setq gelay (tblsearch "layer" lay)
            colay (cdr (assoc 62 gelay))
            ltlay (cdr (assoc 6 gelay))
            newl (strcat sub "-" lay)
      )
      (if (not (tblsearch "Layer" newl))
        (vl-cmdf "-Layer" "M" newl "C" colay "" "L" ltlay "" "")
      )
      (sssetfirst nil ss)
      (setq SS1 (ssget (list (cons 8 lay))))
      (prompt (strcat "\n" (itoa (sslength SS1)) " Elements coverted to " newl " layer"))
      (vl-cmdf "chprop" SS1 "" "la" newl "")
    )
  )
  (setvar 'clayer oldlayer)
  (setvar "cmdecho" 1)
  (princ)
)

 

[tombu]

Existence of DXF code 420 indicates True Color, test for that and use vla-get-Color & vl-catch-all-apply 'vla-put-Color if it does.

Haven't tried it on a Layer table entry though.

[Steven P]

I know this isn't what you asked but wuld this be any help from Lee Mac? http://www.lee-mac.com/pslay.html

[mhupp]

14 hours ago, tombu said:

Existence of DXF code 420 indicates True Color, test for that and use vla-get-Color & vl-catch-all-apply 'vla-put-Color if it does.

Haven't tried it on a Layer table entry though.

layer table in bricsCAD only returns the following.

(setq gelay (tblsearch "layer" lay) = ((0 . "LAYER") (2 . "0") (70 . 0) (62 . 7) (6 . "Continuous"))

Edited August 26, 2021 by mhupp
Example

[tombu]

7 hours ago, mhupp said:

layer table in bricsCAD only returns the following.

(setq gelay (tblsearch "layer" lay) = ((0 . "LAYER") (2 . "0") (70 . 0) (62 . 7) (6 . "Continuous"))

(tblsearch "LAYER" "parnal")
((0 . "LAYER") (2 . "parnal") (70 . 0) (62 . 195) (6 . "Continuous"))

Sorry layer table in AutoCAD didn't work either. Must only work on entities.

[tombu]

Command: (entget(tblobjname "LAYER" "parnal")) returns
((-1 . <Entity name: 25e8f2e95b0>) (0 . "LAYER") (330 . <Entity name: 25e8f2b9020>) (5 . "10973") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "parnal") (70 . 5) (62 . -195) (420 . 8078013) (6 . "Continuous") (290 . 0) (370 . 30) (390 . <Entity name: 25eeb0735a0>) (347 . <Entity name: 25e8f2c1370>) (348 . <Entity name: 0>))

This way seems to work!

[mhupp]

off of what @tombu posted was able to update the code to work with true color. it will error if its 256 color coded.

 

(defun c:vv (/ oldlayer sub ss ss1 layname laylst gelay ltlay  colay newl)
  (setvar 'cmdecho 0)
  (setq oldlayer (getvar 'clayer))
  (setq sub (getstring "\n Give prefix to layername: "))
  (setq ss (ssget "_:L"))
  (if (= ss nil)
    (princ "\nNo elements selected")
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      (if (not (vl-position (setq layname (cdr (assoc 8 (entget e)))) laylst))
        (setq laylst (cons layname laylst))
      )
    )
  )
  (if (not (= laylst nil))
    (foreach lay laylst
      (setq gelay (entget(tblobjname "LAYER" lay))
            ltlay (cdr (assoc 6 gelay))
            newl (strcat sub "-" lay)
      )
      (if (setq colay (cdr (assoc 420 gelay)))
        (setq colay (LM:True->RGB colay)
              colay (strcat (nth 0 colay) "," (nth 1 colay) "," (nth 2 colay))
        )
        (setq colay (cdr (assoc 62 gelay)))
      )
      (if (not (tblsearch "Layer" newl))
        (vl-cmdf "-Layer" "M" newl "C" colay "" "L" ltlay "" "")
      )
      (sssetfirst nil ss)
      (setq SS1 (ssget (list (cons 8 lay))))
      (prompt (strcat"\nElements coverted to " newl " layer"))
      (vl-cmdf "chprop" SS1 "" "la" newl "")
    )
  )
  (setvar 'clayer oldlayer)
  (setvar "cmdecho" 1)
  (princ)
)
;; True -> RGB  -  Lee Mac
;; Args: c - True Colour
(defun LM:True->RGB ( c )
    (list
        (itoa (lsh (lsh (fix c) 08) -24))
        (itoa (lsh (lsh (fix c) 16) -24))
        (itoa (lsh (lsh (fix c) 24) -24))
    )
)

 

Edited August 31, 2021 by mhupp
fixed code

[AlexODCM]

On 8/26/2021 at 9:53 PM, mhupp said:

off of what @tombu posted was able to update the code to work with true color. it will error if its 256 color coded.

 

(defun c:vv (/ oldlayer sub ss ss1 layname laylst gelay ltlay  colay newl)
  (setvar 'cmdecho 0)
  (setq oldlayer (getvar 'clayer))
  (setq sub (getstring "\n Give prefix to layername: "))
  (setq ss (ssget "_:L"))
  (if (= ss nil)
    (princ "\nNo elements selected")
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      (if (not (vl-position (setq layname (cdr (assoc 8 (entget e)))) laylst))
        (setq laylst (cons layname laylst))
      )
    )
  )
  (if (not (= laylst nil))
    (foreach lay laylst
      (setq gelay (entget(tblobjname "LAYER" lay))
            ltlay (cdr (assoc 6 gelay))
            newl (strcat sub "-" lay)
      )
      (if (setq colay (cdr (assoc 420 gelay)))
        (setq colay (LM:True->RGB colay)
              colay (strcat (nth 0 colay) "," (nth 1 colay) "," (nth 2 colay))
        )
        (setq colay (cdr (assoc 62 gelay)))
      )
      (if (not (tblsearch "Layer" newl))
        (vl-cmdf "-Layer" "M" newl "C" colay "" "L" ltlay "" "")
      )
      (sssetfirst nil ss)
      (setq SS1 (ssget (list (cons 8 lay))))
      (prompt "\nElements coverted to " newl " layer"))
      (vl-cmdf "chprop" SS1 "" "la" newl "")
    )
  )
  (setvar 'clayer oldlayer)
  (setvar "cmdecho" 1)
  (princ)
)
;; True -> RGB  -  Lee Mac
;; Args: c - True Colour
(defun LM:True->RGB ( c )
    (list
        (itoa (lsh (lsh (fix c) 08) -24))
        (itoa (lsh (lsh (fix c) 16) -24))
        (itoa (lsh (lsh (fix c) 24) -24))
    )
)

 

Hi Guys,

 

First off all: Thanks for the efforts.

But for the moment it does not work for me.

 

The one form @tombu does not mess with the truecolor, but it also does not give a prefix, the layer name stays the same.

The other suggestions also just gave the new layer the prefix but cancelled the truecolor out to color 252 again, so no truecolor properties taken over.

 

Please let me know if this is something that always will be happening, because you can give the item a color and then the command does not change that color, as it is not attached to the layer but the specific object. given a prefix with a truecolor for example.

 

I have attached the example of what should be having a prefix that we use daily.

 

item_tester.dwg

[Steven P]

Did you try the link to Lee Macs Layer prefix LISP? He is normally pretty good (I say that because one day he might get something wrong, but he hasn't yet that i've seen)

[mhupp]

That's my bad was missing a ")"

 

 

(defun c:vv (/ oldlayer sub ss ss1 layname laylst gelay ltlay  colay newl)
  (setvar 'cmdecho 0)
  (setq oldlayer (getvar 'clayer))
  (setq sub (getstring "\n Give prefix to layername: "))
  (setq ss (ssget "_:L"))
  (if (= ss nil)
    (princ "\nNo elements selected")
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
      (if (not (vl-position (setq layname (cdr (assoc 8 (entget e)))) laylst))
        (setq laylst (cons layname laylst))
      )
    )
  )
  (if (not (= laylst nil))
    (foreach lay laylst
      (setq gelay (entget(tblobjname "LAYER" lay))
            ltlay (cdr (assoc 6 gelay))
            newl (strcat sub "-" lay)
      )
      (if (setq colay (cdr (assoc 420 gelay)))
        (setq colay (LM:True->RGB colay)
              colay (strcat (nth 0 colay) "," (nth 1 colay) "," (nth 2 colay))
        )
        (setq colay (cdr (assoc 62 gelay)))
      )
      (if (not (tblsearch "Layer" newl))
        (vl-cmdf "-Layer" "M" newl "C" colay "" "L" ltlay "" "")
      )
      (sssetfirst nil ss)
      (setq SS1 (ssget (list (cons 8 lay))))
      (prompt (strcat"\nElements coverted to " newl " layer"))
      (vl-cmdf "chprop" SS1 "" "la" newl "")
    )
  )
  (setvar 'clayer oldlayer)
  (setvar 'cmdecho 1)
  (princ)
)
;; True -> RGB  -  Lee Mac
;; Args: c - True Colour
(defun LM:True->RGB ( c )
    (list
        (itoa (lsh (lsh (fix c) 08) -24))
        (itoa (lsh (lsh (fix c) 16) -24))
        (itoa (lsh (lsh (fix c) 24) -24))
    )
)

 

Edited September 1, 2021 by mhupp