Help with Lisp: Create a new layer and set ByLayer based on source objects

[pondpepo9]

I am requesting assistance in creating a Lisp routine that can:

Generate a new layer.

Duplicate the linetype, linewidth, and color properties of selected objects onto this new layer.

Subsequently, set the layer properties to "ByLayer".

Essentially, I would like to create a Lisp that allows me to draw on any layer, but when I need to switch to a new layer, it automatically generates a layer with the same linetype, linewidth, and color as the original objects, and then sets the layer properties to "ByLayer".

[BIGAL]

This will copy last entity property 

 

(defun c:laym ( / obj col lin linw)

; (setq obj (vlax-ename->vla-object (car (entsel "\nPick a object ")))) ; pick object
(setq obj (vlax-ename->vla-object (entlast))) ; use last object

(setq col (vlax-get obj 'color))
(setq lin (vlax-get obj 'linetype))
(setq linw (vlax-get obj 'lineweight))

(setq str (getstring "\nEnter new layer name " T))
(command "-layer" "M" str "c" col "" "L" lin "" "LW" linw "" "")

(princ)
)

(defun c:LLL ()(c:laym)) ; easy type

 

[pondpepo9]

On 9/2/2024 at 10:36 AM, BIGAL said:

This will copy last entity property 

 

(defun c:laym ( / obj col lin linw)

; (setq obj (vlax-ename->vla-object (car (entsel "\nPick a object ")))) ; pick object
(setq obj (vlax-ename->vla-object (entlast))) ; use last object

(setq col (vlax-get obj 'color))
(setq lin (vlax-get obj 'linetype))
(setq linw (vlax-get obj 'lineweight))

(setq str (getstring "\nEnter new layer name " T))
(command "-layer" "M" str "c" col "" "L" lin "" "LW" linw "" "")

(princ)
)

(defun c:LLL ()(c:laym)) ; easy type

 

I tried using the laym command in AutoCAD LT 2024. Then, it prompted me to name a layer. After naming it, the program encountered an error and became unusable. Please help me.
 

[Steven P]

AutoCAD LT doesn't have full LISP abilities so need to look at a slightly different way to do this I think

[SLW210]

You should correct your information to inform everyone that you are using AutoCAD 2024 LT.

[Steven P]

This one might work better with LT

 

(defun c:laym ( / )

;;Select Entities
;  (setq MyEnt (entget (car (entsel "\nPick a object ")))) ; pick object
  (setq MyEnt (entget (entlast))) ; use last object

;;Extract information
  (setq col (cdr (assoc 62 MyEnt)))
  (setq lin (cdr (assoc 6 MyEnt)))
  (setq linw (cdr (assoc 370 MyEnt)))
  (setq lay (entget (tblobjname "layer" (cdr (assoc 8 MyEnt)))) )

;;Set information to layer details if 'by layer' or 'by block'
  (if (= col nil)(setq col (cdr (assoc 62 lay))) )
  (if (= lin nil)(setq lin (cdr (assoc 6 lay))) )
  (if (= linw nil)(setq linw (cdr (assoc 370 lay))) )
  (if (= linw nil)(setq linw -3)) ;;lineweight to default

  (setq str (getstring "\nEnter new layer name " T))
  (setq LayerFree 0) ;;Freeze new layer if 1
  (setq LayerPlot 1) ;;layer plots if 1

;;Create Layer
  (setq NewLayer (entmakex (list
      '(0 . "LAYER")
      (cons 100 "AcDbSymbolTableRecord")
      (cons 100 "AcDbLayerTableRecord")
      (cons 2 str)                                       ; Layer Name
      (if (= LayerFree 1) (cons 70 1) (cons 70 0))       ; Freeze
      (if (= col nil)() (cons 62 col))                   ; colour. -ve for layer off
      (if (= Lin nil)(cons 6 "Continuous") (cons 6 Lin)) ; Line type
      (if (= LayerPlot 1) (cons 290 1) (cons 290 0))     ; Plot
      (if (= Linw nil) () (cons 370 Linw))               ; line weight
    ))); end list ; end entmake ; end setq

;;Set entity to new layer
  (setq MyEnt (subst (cons 8 str) (assoc 8 MyEnt) MyEnt ))
;;Add in here if you want other entity properties to 'by layer' etc
  (entmod MyEnt)

  (princ)
)

 

[Tsuky]

Or this ? minimally tested

(defun c:foo ( / ent dxf_ent l_prop lay_name)
  (while (not (setq ent (entsel "\nSelect an object: ")))
    (princ "\nMissing...")
  )
  (setq dxf_ent (entget (car ent)))
  (setq
    l_prop
    (mapcar
      '(lambda (x)
        (if (assoc x dxf_ent)
          (cdr (assoc x dxf_ent))
          (cdr (assoc x (entget (tblobjname "LAYER" (cdr (assoc 8 dxf_ent))))))
        )
      )
      '(6 62 370)
    )
  )
  (while (wcmatch (setq lay_name (getstring "\nEnter layer name: " T)) "*[`?`,```*\\\"<>/=|:]*")
    (princ "\nIncorrect layer name, try again")
  )
  (if (not (tblsearch "LAYER" lay_name))
    (entmake
      (list
        '(0 . "LAYER")
        '(100 . "AcDbSymbolTableRecord")
        '(100 . "AcDbLayerTableRecord")
        (cons 2 lay_name)
        '(70 . 0)
        (cons 62 (cadr l_prop))
        (cons 370 (caddr l_prop))
        (cons 6 (car l_prop))
      )
    )
    (mapcar
      '(lambda (x y)
        (entmod
          (subst
            (cons x y)
            (assoc x (entget (tblobjname "LAYER" lay_name)))
            (entget (tblobjname "LAYER"lay_name))
          )
        )
      )
      '(70 6 62 370)
      (cons 0 l_prop)
    )
  )
  (setvar "CLAYER" lay_name)
  (prin1)
)

 

[BIGAL]

Not sure if this is supported in LT 2024 can you test please. Should return the color. Just copy to command line.

 

(getpropertyvalue (car (entsel "\nPick an object ")) "Color")

 

[pondpepo9]

13 hours ago, Tsuky said:

Or this ? minimally tested

(defun c:foo ( / ent dxf_ent l_prop lay_name)
  (while (not (setq ent (entsel "\nSelect an object: ")))
    (princ "\nMissing...")
  )
  (setq dxf_ent (entget (car ent)))
  (setq
    l_prop
    (mapcar
      '(lambda (x)
        (if (assoc x dxf_ent)
          (cdr (assoc x dxf_ent))
          (cdr (assoc x (entget (tblobjname "LAYER" (cdr (assoc 8 dxf_ent))))))
        )
      )
      '(6 62 370)
    )
  )
  (while (wcmatch (setq lay_name (getstring "\nEnter layer name: " T)) "*[`?`,```*\\\"<>/=|:]*")
    (princ "\nIncorrect layer name, try again")
  )
  (if (not (tblsearch "LAYER" lay_name))
    (entmake
      (list
        '(0 . "LAYER")
        '(100 . "AcDbSymbolTableRecord")
        '(100 . "AcDbLayerTableRecord")
        (cons 2 lay_name)
        '(70 . 0)
        (cons 62 (cadr l_prop))
        (cons 370 (caddr l_prop))
        (cons 6 (car l_prop))
      )
    )
    (mapcar
      '(lambda (x y)
        (entmod
          (subst
            (cons x y)
            (assoc x (entget (tblobjname "LAYER" lay_name)))
            (entget (tblobjname "LAYER"lay_name))
          )
        )
      )
      '(70 6 62 370)
      (cons 0 l_prop)
    )
  )
  (setvar "CLAYER" lay_name)
  (prin1)
)

 

"Thank you very much. It works well in CAD LT 2024. I've created a layer and copied the line color. I'm wondering if it's possible to also copy the transparency?"

[pondpepo9]

1 hour ago, BIGAL said:

Not sure if this is supported in LT 2024 can you test please. Should return the color. Just copy to command line.

 

(getpropertyvalue (car (entsel "\nPick an object ")) "Color")

 

"Thank you very much for your help. Unfortunately, I'm not very good with programs. I can only copy and paste code."

[BIGAL]

Just copy the line to the command line you should get a number returned that is the object color. I dont have LT so can not check what works I am trying to find out if "getpropertyvalue" works. It makes getting properties much easier.

[Steven P]

8 hours ago, pondpepo9 said:

"Thank you very much. It works well in CAD LT 2024. I've created a layer and copied the line color. I'm wondering if it's possible to also copy the transparency?"

 

Simplest way would be to use BigAls method of

(command "-layer" "Tr" -Transparency- -Layer- "")

 

You'd need to get the transparency from the entity first (assoc code 440) but that is not a simple percent number - I'd need to look at that

 

EDIT to convert assoc 40 from an entity to a percent number:

;;https://adndevblog.typepad.com/autocad/2013/04/get-and-set-layer-and-entity-transparency-using-lisp.html#:~:text=The%20properties%20that
 

(setq transparency (lsh (lsh transparency 24) -24)) ;;8 digit number
(setq transparency (fix (- 100 (/ transparency 2.55)))) 

 

You could do it with mine or Tsukys entmake method, a bit longer code, see Lee Macs code here https://www.theswamp.org/index.php?topic=52473.msg574001#msg574001 (you might need to sign up to access this). I'll try to put something together today to make that work for you.

Edited September 4 by Steven P

[Steven P]

Returning to this one, it should set up a layer with transparency according to the entity selected

 

EDIT: Should have said, I 've added some of Tsukys ideas in here as well

 

(defun c:laym ( / )
;;Sub functions
;;https://www.theswamp.org/index.php?topic=52473.msg574001#msg574001
  (defun LM:trans->dxf ( x )
    (logior (fix (* 2.55 (- 100 x))) 33554432)
  )
  (defun LM:dxf->trans ( x )
    (fix (- 100 -1e-8 (/ (logand x (~ 33554432)) 2.55)))
  )
  (defun LM:getlayertransparency ( lay / ent dxf )
    (if (and (setq ent (tblobjname "layer" lay))
             (setq dxf (cdr (assoc 1071 (cdadr (assoc -3 (entget ent '("accmtransparency")))))))
        )
        (LM:dxf->trans dxf)
    )
  )
  (defun LM:setlayertransparency ( lay trn / ent )
    (if (setq ent (tblobjname "layer" lay))
      (progn
        (regapp "accmtransparency")
        (entmod
          (append (entget ent)
            (list
              (list -3
                (list "accmtransparency"
                  (cons 1071 (LM:trans->dxf trn))
                )
              )
            )
          )
        )
      )
    )
  )
;;End subfunctions

;;Select Entities

  (if (setq MyEnt (entget (car (entsel "\nPick a object ")))) ; pick object
;  (if (setq MyEnt (entget (entlast)))                         ; use last object
    (progn

;;Extract information
  (setq col (cdr (assoc 62 MyEnt)))   ;Colour
  (setq lin (cdr (assoc 6 MyEnt)))    ;Line Type
  (setq linw (cdr (assoc 370 MyEnt))) ;Line weight
  (setq trans (cdr (assoc 440 MyEnt)));Transparency
  (setq lay (entget (tblobjname "layer" (cdr (assoc 8 MyEnt)))) ) ; Layer

;;Set information to layer details if 'by layer' or 'by block'
  (if (= col nil)  (setq col (cdr (assoc 62 lay))) )   ; Set colour to layer colour if not defined
  (if (= lin nil)  (setq lin (cdr (assoc 6 lay))) )    ; ... and line type
  (if (= linw nil) (setq linw (cdr (assoc 370 lay))) ) ; ... and line weight
  (if (= linw nil) (setq linw -3))                     ; ... if layer has no specific line weight, use default 
  (if (= trans nil)(setq trans (LM:getlayertransparency (cdr (assoc 8 MyEnt)))) ) ; ... and transparency
  (if (= trans nil)(setq trans 0))                     ; if still no transparency set
  
  (while (wcmatch (setq str (getstring "\nEnter new layer name: " T)) "*[`?`,```*\\\"<>/=|:]*") ; enter layer name
    (princ "\nInvalid layer name, try again (some invalid characters)")
  )

  (setq LayerFree 0) ;;Freeze new layer if 1
  (setq LayerPlot 1) ;;layer plots if 1

;;Create Layer
  (if (tblsearch "LAYER" str) ; if the layer name exists.. do nothing apart from command line message
    (princ "\nLayer exists. Moving selected entity to layer, layer unchanged.")
    (progn

    (setq NewLayer (entmakex (list                      ; Make new layer
      '(0 . "LAYER")
      (cons 100 "AcDbSymbolTableRecord")
      (cons 100 "AcDbLayerTableRecord")
      (cons 2 str)                                       ; Layer Name
      (if (= LayerFree 1) (cons 70 1) (cons 70 0))       ; Freeze
      (if (= col nil)() (cons 62 col))                   ; colour. -ve for layer off
      (if (= Lin nil)(cons 6 "Continuous") (cons 6 Lin)) ; Line type
      (if (= LayerPlot 1) (cons 290 1) (cons 290 0))     ; Plot
      (if (= Linw nil) () (cons 370 Linw))               ; line weight
    ))); end list ; end entmakez ; end setq              ; Layer created
    (LM:setlayertransparency str (LM:dxf->trans trans))  ; Set Transparency

    ) ; end progn
  ) ; end if layer exists

;;Set entity to new layer
  (setq MyEnt (subst (cons 8 str) (assoc 8 MyEnt) MyEnt ))
;;Add in here if you want other entity properties to 'by layer' etc
  (entmod MyEnt)

    ) ; end progn
    (progn
      (princ "\nEntity not selected.")
    ) ; end progn
  ) ; end if entity selected

  (princ)
)

 

Edited Friday at 08:06 AM by Steven P

[pondpepo9]

On 9/6/2024 at 5:07 PM, Steven P said:

Returning to this one, it should set up a layer with transparency according to the entity selected

 

EDIT: Should have said, I 've added some of Tsukys ideas in here as well

 

(defun c:laym ( / )
;;Sub functions
;;https://www.theswamp.org/index.php?topic=52473.msg574001#msg574001
  (defun LM:trans->dxf ( x )
    (logior (fix (* 2.55 (- 100 x))) 33554432)
  )
  (defun LM:dxf->trans ( x )
    (fix (- 100 -1e-8 (/ (logand x (~ 33554432)) 2.55)))
  )
  (defun LM:getlayertransparency ( lay / ent dxf )
    (if (and (setq ent (tblobjname "layer" lay))
             (setq dxf (cdr (assoc 1071 (cdadr (assoc -3 (entget ent '("accmtransparency")))))))
        )
        (LM:dxf->trans dxf)
    )
  )
  (defun LM:setlayertransparency ( lay trn / ent )
    (if (setq ent (tblobjname "layer" lay))
      (progn
        (regapp "accmtransparency")
        (entmod
          (append (entget ent)
            (list
              (list -3
                (list "accmtransparency"
                  (cons 1071 (LM:trans->dxf trn))
                )
              )
            )
          )
        )
      )
    )
  )
;;End subfunctions

;;Select Entities

  (if (setq MyEnt (entget (car (entsel "\nPick a object ")))) ; pick object
;  (if (setq MyEnt (entget (entlast)))                         ; use last object
    (progn

;;Extract information
  (setq col (cdr (assoc 62 MyEnt)))   ;Colour
  (setq lin (cdr (assoc 6 MyEnt)))    ;Line Type
  (setq linw (cdr (assoc 370 MyEnt))) ;Line weight
  (setq trans (cdr (assoc 440 MyEnt)));Transparency
  (setq lay (entget (tblobjname "layer" (cdr (assoc 8 MyEnt)))) ) ; Layer

;;Set information to layer details if 'by layer' or 'by block'
  (if (= col nil)  (setq col (cdr (assoc 62 lay))) )   ; Set colour to layer colour if not defined
  (if (= lin nil)  (setq lin (cdr (assoc 6 lay))) )    ; ... and line type
  (if (= linw nil) (setq linw (cdr (assoc 370 lay))) ) ; ... and line weight
  (if (= linw nil) (setq linw -3))                     ; ... if layer has no specific line weight, use default 
  (if (= trans nil)(setq trans (LM:getlayertransparency (cdr (assoc 8 MyEnt)))) ) ; ... and transparency
  
  (while (wcmatch (setq str (getstring "\nEnter new layer name: " T)) "*[`?`,```*\\\"<>/=|:]*") ; enter layer name
    (princ "\nInvalid layer name, try again (some invalid characters)")
  )

  (setq LayerFree 0) ;;Freeze new layer if 1
  (setq LayerPlot 1) ;;layer plots if 1

;;Create Layer
  (if (tblsearch "LAYER" str) ; if the layer name exists.. do nothing apart from command line message
    (princ "\nLayer exists. Moving selected entity to layer, layer unchanged.")
    (progn

    (setq NewLayer (entmakex (list                      ; Make new layer
      '(0 . "LAYER")
      (cons 100 "AcDbSymbolTableRecord")
      (cons 100 "AcDbLayerTableRecord")
      (cons 2 str)                                       ; Layer Name
      (if (= LayerFree 1) (cons 70 1) (cons 70 0))       ; Freeze
      (if (= col nil)() (cons 62 col))                   ; colour. -ve for layer off
      (if (= Lin nil)(cons 6 "Continuous") (cons 6 Lin)) ; Line type
      (if (= LayerPlot 1) (cons 290 1) (cons 290 0))     ; Plot
      (if (= Linw nil) () (cons 370 Linw))               ; line weight
    ))); end list ; end entmakez ; end setq              ; Layer created
    (LM:setlayertransparency str (LM:dxf->trans trans))  ; Set Transparency

    ) ; end progn
  ) ; end if layer exists

;;Set entity to new layer
  (setq MyEnt (subst (cons 8 str) (assoc 8 MyEnt) MyEnt ))
;;Add in here if you want other entity properties to 'by layer' etc
  (entmod MyEnt)

    ) ; end progn
    (progn
      (princ "\nEntity not selected.")
    ) ; end progn
  ) ; end if entity selected

  (princ)
)

 

I'm so sorry for the delayed response. I've been swamped with work. I've had a chance to try out AutoCAD LT 2024 and I'm impressed with how well it functions. It's a valuable tool for anyone in need of a CAD program. Thanks again for your assistance

Can I specify exact RGB color values in AutoCAD LT 2024? I've noticed that the program often suggests similar colors when creating layers.

Edited Friday at 03:26 AM by pondpepo9