Jump to content

Demo Lisp

CAD_Noob

By CAD_Noob
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

CAD_Noob Collaborator

CAD_Noob

Posted
Posted (edited)

I found this lisp by Kent which enable the user to pick an entity and add "-DEMO" to its layer name, change its color and linetype which is working great.

Can this be modified to accept multiple selection rather than by pick only.
And if i select a block if does not change the color and linetype.

  

(defun c:DEMO (/ esel ent DLname)
  (while (setq esel (entsel "\nPick object to put on its Demo Layer: "))
    (setq
      ent (car esel)
      DLname (strcat (cdr (assoc 8 (entget ent))) "-DEMO")
    )
    (command
      "_.layer" "_make" DLname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
      "_.chprop" ent "" "_layer" DLname ""
    )
  )
  (princ)
)

 

Edited by CAD_Noob
typo error
Emmanuel Delay Proficient

Emmanuel Delay

Posted
Posted (edited)

Sure, I renamed the command CLCL

  

(defun change_layer_color_ltp ( ent /  DLname)
    (setq
      ;;ent (car esel)
      DLname (strcat (cdr (assoc 8 (entget ent))) "-DEMO")
    )
    (command
      "_.layer" "_make" DLname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
      "_.chprop" ent "" "_layer" DLname ""
    )
  (princ)
)

(defun c:clcl ( / ss i)
  ;; selection
  (princ "\nMake selection: ")
  (setq ss (ssget))
  ;; now perform the function for every selected entity
  (setq i 0)
  (repeat (sslength ss)
    (change_layer_color_ltp (ssname ss i))
    (setq i (+ i 1))
  )
  (princ)
)
Edited by Emmanuel Delay
  • Like 2
  • Thanks 1
CAD_Noob Collaborator

CAD_Noob

Posted
  • Author
Posted
3 hours ago, Emmanuel Delay said:

Sure, I renamed the command CLCL

  


(defun change_layer_color_ltp ( ent /  DLname)
    (setq
      ;;ent (car esel)
      DLname (strcat (cdr (assoc 8 (entget ent))) "-DEMO")
    )
    (command
      "_.layer" "_make" DLname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
      "_.chprop" ent "" "_layer" DLname ""
    )
  (princ)
)

(defun c:clcl ( / ss i)
  ;; selection
  (princ "\nMake selection: ")
  (setq ss (ssget))
  ;; now perform the function for every selected entity
  (setq i 0)
  (repeat (sslength ss)
    (change_layer_color_ltp (ssname ss i))
    (setq i (+ i 1))
  )
  (princ)
)

 

Hi @Emmanuel Delay; thanks for this. Will try tomorrow as I do not have AutoCAD at home.

 

  • Like 1
CAD_Noob Collaborator

CAD_Noob

Posted
  • Author
Posted

Thanks so much! working well.

Just need to edit some blocks to ByLayer for the routine to take effect.

Some blocks are a bit hard to edit though there are couples of nested block 

CAD_Noob Collaborator

CAD_Noob

Posted
  • Author
Posted

Hi found a bug...
if the selected item happens to be in the demo layer already it again adds "-DEMO" suffix.

Example : 
Before : A-_Door-DEMO
After : A-_Door-DEMO-DEMO

dlanorh Mentor

dlanorh

Posted
Posted

It's not a bug, it's user error for selecting an entity on a layer with the suffix "-DEMO" :lol:

 

A belt and braces lisp. You can't select a layer with "-DEMO" in the layer name

If the layer already has an associated "-demo" layer it moves it to that layer 

Otherwise it creates the demo layer and moves it.

  


(defun change_layer_color_ltp ( ent /  dlname)
    (setq dlname (cdr (assoc 8 (entget ent))))
    (cond ( (and (not (wcmatch (strcase dlname) "*-DEMO"))
                 (setq dlname (strcat dlname "-DEMO"))
                 (not (tblsearch "layer" dlname))
            )
            (command "_.layer" "_make" dlname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
                    "_.chprop" ent "" "_layer" DLname ""
            )
          )
          ( (tblsearch "layer" dlname) (command "_.chprop" ent "" "_layer" dlname ""))
    )
  (princ)
)

(defun c:clcl ( / ss i)
  ;; selection
  (princ "\nMake selection: ")
  (setq ss (ssget '((-4 . "<NOT") (8 . "*DEMO") (-4 . "NOT>"))))
  ;; now perform the function for every selected entity
  (setq i 0)
  (repeat (sslength ss)
    (change_layer_color_ltp (ssname ss i))
    (setq i (+ i 1))
  )
  (princ)
)

 

  • Like 2
CAD_Noob Collaborator

CAD_Noob

Posted
  • Author
Posted
14 hours ago, dlanorh said:

It's not a bug, it's user error for selecting an entity on a layer with the suffix "-DEMO" :lol:

 

A belt and braces lisp. You can't select a layer with "-DEMO" in the layer name

If the layer already has an associated "-demo" layer it moves it to that layer 

Otherwise it creates the demo layer and moves it.

  


(defun change_layer_color_ltp ( ent /  dlname)
    (setq dlname (cdr (assoc 8 (entget ent))))
    (cond ( (and (not (wcmatch (strcase dlname) "*-DEMO"))
                 (setq dlname (strcat dlname "-DEMO"))
                 (not (tblsearch "layer" dlname))
            )
            (command "_.layer" "_make" dlname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
                    "_.chprop" ent "" "_layer" DLname ""
            )
          )
          ( (tblsearch "layer" dlname) (command "_.chprop" ent "" "_layer" dlname ""))
    )
  (princ)
)

(defun c:clcl ( / ss i)
  ;; selection
  (princ "\nMake selection: ")
  (setq ss (ssget '((-4 . "<NOT") (8 . "*DEMO") (-4 . "NOT>"))))
  ;; now perform the function for every selected entity
  (setq i 0)
  (repeat (sslength ss)
    (change_layer_color_ltp (ssname ss i))
    (setq i (+ i 1))
  )
  (princ)
)

 

 

Thanks for the fix, sometimes some of those demo layers are accidentally selected when windowing

CAD_Noob Collaborator

CAD_Noob

Posted
  • Author
Posted
15 hours ago, dlanorh said:

It's not a bug, it's user error for selecting an entity on a layer with the suffix "-DEMO" :lol:

 

A belt and braces lisp. You can't select a layer with "-DEMO" in the layer name

If the layer already has an associated "-demo" layer it moves it to that layer 

Otherwise it creates the demo layer and moves it.

  


(defun change_layer_color_ltp ( ent /  dlname)
    (setq dlname (cdr (assoc 8 (entget ent))))
    (cond ( (and (not (wcmatch (strcase dlname) "*-DEMO"))
                 (setq dlname (strcat dlname "-DEMO"))
                 (not (tblsearch "layer" dlname))
            )
            (command "_.layer" "_make" dlname "_color" 40 "" "_ltype" "HIDDEN2" "" ""
                    "_.chprop" ent "" "_layer" DLname ""
            )
          )
          ( (tblsearch "layer" dlname) (command "_.chprop" ent "" "_layer" dlname ""))
    )
  (princ)
)

(defun c:clcl ( / ss i)
  ;; selection
  (princ "\nMake selection: ")
  (setq ss (ssget '((-4 . "<NOT") (8 . "*DEMO") (-4 . "NOT>"))))
  ;; now perform the function for every selected entity
  (setq i 0)
  (repeat (sslength ss)
    (change_layer_color_ltp (ssname ss i))
    (setq i (+ i 1))
  )
  (princ)
)

 

 

one last request please? exclude xref from the selection...

 

  • 2 years later...
grantm Newbie

grantm

Posted
Posted

Hello,

Great code. Can this code be updated to include adopting the source line type and line weight of the layer picked?

 

Thanks

Emmanuel Delay Proficient

Emmanuel Delay

Posted
Posted
20 hours ago, grantm said:

Hello,

Great code. Can this code be updated to include adopting the source line type and line weight of the layer picked?

 

Thanks

 

That's quite another requirement.

Are you happy with this:

Command MCTW

- select a source element (line, or whatever).

- Then select a destination selection set.  The destination set gets the layer, color, line type, line weight of the source.

(I think it doesn't work perfectly if true color (RGB) is involved)

  


(vl-load-com)

(defun match_props ( ent layer col lt lw /  )
	(entmod (subst (cons 8 layer) 	(assoc 8 (entget ent)) 		(entget ent) ))  ;; substitute layer
	;; if this property is ByLayer, then it's empty and we have to add it.  else we substitute it.  Dito for follomwing If-statements 
	(if (assoc 62 (entget ent))  
		(entmod (subst (cons 62 col) 	(assoc 62 (entget ent)) 	(entget ent) ))  ;; substitute/add color
		(entmod (append (entget ent) (list (cons 62 col)  ) ))
	)
	(if (assoc 6 (entget ent))  
		(entmod (subst (cons 6 lt) 	(assoc 6 (entget ent)) 	(entget ent) ))  ;; substitute/add line type
		(entmod (append (entget ent) (list (cons 6 lt)  ) ))
	)
	(if (assoc 370 (entget ent))  
		(entmod (subst (cons 370 lw) 	(assoc 370 (entget ent)) 	(entget ent) ))  ;; substitute/add lline weight
		(entmod (append (entget ent) (list (cons 370 lw)  ) ))
	)
)

;; Match Color, line Type, and line Weight of the layer picked
(defun c:MCTW ( / source layer col lt lw ss i)
;; select source, read its properties
	(setq source (car (entsel "\nSelect source: ")))
	(setq layer (cdr (assoc 8 (entget source))))	;; layer
	(setq col (cdr (assoc 62 (entget source))))	;; color
	(setq lt (cdr (assoc 6 (entget source))))	;; line type
	(setq lw (cdr (assoc 370 (entget source))))	;; line weight
;; select destination selection
	;; selection
	(princ "\nMake selection: ")
	(setq ss (ssget))
	;; now perform the function for every selected entity
	(setq i 0)
	(repeat (sslength ss)
		(match_props  (ssname ss i) layer col lt lw)
		(setq i (+ i 1))
	)
	(princ)
)

 

ronjonp Grand Master

ronjonp

Posted
Posted (edited)
On 6/27/2022 at 8:15 AM, grantm said:

Hello,

Great code. Can this code be updated to include adopting the source line type and line weight of the layer picked?

 

Thanks

Here's another I've had in the toolbox for a while: 

(defun c:layersuffix (/ e el l f s tm)
  ;; RJP - 04.03.2018
  (or (setq f (getenv "RJP_LayerSuffix")) (setq f (getenv "username")))
  (cond	((and (setq f (cond ((/= "" (setq tm (getstring (strcat "\nEnter suffix [<" f ">]: ")))) tm)
			    (f)
		      )
	      )
	      (setq s (ssget ":L" (list '(-4 . "<NOT") (cons 8 (strcat "*" f)) '(-4 . "NOT>"))))
	 )
	 (setenv "RJP_LayerSuffix" f)
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (setq el (entget (tblobjname "layer" (setq l (cdr (assoc 8 (entget e)))))))
	   (or (tblobjname "layer" (setq nl (strcat l f)))
	       (entmakex (subst (cons 2 nl) (assoc 2 el) el))
	   )
	   (entmod (subst (cons 8 nl) (assoc 8 (entget e)) (entget e)))
	 )
	)
  )
  (princ)
)

 

Edited by ronjonp
  • 1 month later...
turbosocks Newbie

turbosocks

Posted
Posted

This is almost exactly what I was looking for, for our Engineering group.

 

I am terrible at manipulating LISP routines when it involves anything more than Find/Replace.

 

I am looking to make the layer DEMO-(Layer Name) instead of (Layer Name)-DEMO. Basically prefix instead of suffix. Is there an easy way to do this?

 

 

ronjonp Grand Master

ronjonp

Posted
Posted
23 hours ago, turbosocks said:

This is almost exactly what I was looking for, for our Engineering group.

 

I am terrible at manipulating LISP routines when it involves anything more than Find/Replace.

 

I am looking to make the layer DEMO-(Layer Name) instead of (Layer Name)-DEMO. Basically prefix instead of suffix. Is there an easy way to do this?

 

 

@turbosocks Give this a try. 

(defun c:layerprefix (/ e el l f s tm)
  ;; RJP » 2022-08-12
  (or (setq f (getenv "RJP_LayerPrefix")) (setq f (getenv "username")))
  (cond	((and (setq f (cond ((/= "" (setq tm (getstring (strcat "\nEnter prefix [<" f ">]: ")))) tm)
			    (f)
		      )
	      )
	      (setq s (ssget ":L" (list '(-4 . "<NOT") (cons 8 (strcat f "*")) '(-4 . "NOT>"))))
	 )
	 (setenv "RJP_LayerPrefix" f)
	 (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
	   (setq el (entget (tblobjname "layer" (setq l (cdr (assoc 8 (entget e)))))))
	   (or (tblobjname "layer" (setq nl (strcat f l)))
	       (entmakex (subst (cons 2 nl) (assoc 2 el) el))
	   )
	   (entmod (subst (cons 8 nl) (assoc 8 (entget e)) (entget e)))
	 )
	)
  )
  (princ)
)

 

  • Like 2

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...