Help with complicated lisp

[DC-MWA]

Hi all,

Let's start by saying this is probably one the most "frankenlisp" lisps i've ever done. I really wrestled with this one. I got it to work, but it uses the error handler to end the program when done among other hokie programming issues. It works well enough though and we have been using it for a little over a month. It basically puts objects on demo layers using the object's layer name and adds "-DEMO" to the end. It also changes the wall style if a wall is selected.

Up till now, we have been doing minor demolition work, so picking single items at a time has been fine. Now we have several huge projects with multiple floors being demolished, each with dozens  and dozens if not hundreds of objects being removed or demolished.. The ability to select multiple objects would be very helpful.

I have attached the "frankenslisp". As always, I'm very grateful to any assistance and input received.

[Sea-Haven]

You say change objects but your using entsel which is a single object pick you need to use SSget which is a multiple object pick. 

When you get a object layer do you want all objects on that layer to be chosen again ssget with filter layer.

You can check if its a acdbwall and do the changes also. 

If your using appload or a menu added start on load so no need to type demo.

Rearranged your defuns into a more practical form.

;;DEMOLITION TOOLS FOR MWA

(vl-load-com)

;;;---------------ERROR-----------------------------------
    (defun *error* ( msg )
        (princ "\nDone Demolishing items.")
	(setvar "clayer" oldlayer)
	(setq oldpickbox nil  oldcmd nil oldlayer nil vbobj nil gatherlayer nil newlayername nil *error* nil)
	(command-S "._UNDO" "_End")
	(setvar "cmdecho" 1)
        (princ)
    )
;;;---------------ERROR-------------------------------------

(defun _entsel (msg / p r)
  (setvar "ErrNo" 0)
  (while (not (cond ((and (null (setq p (entsel (strcat "\n" msg)))) (/= 52 (getvar 'errno)));;
		     (prompt "\nAre you blind or what? You missed, try again...")
		    )
		    ((null p) t)
		    ((setq r p))
	      )
	 )
 )
  r
)



(defun changeStylename (myobj newstylename getwid / )
(if (vlax-property-available-p myobj "stylename" t)
(progn ;you can set the stylename on this object
(princ (strcat "\nWall style \"" (vlax-get-property myobj "stylename") "\" changed to \"TBR\""))
(vlax-put-property myobj "stylename" newstylename)
(vlax-put-property myobj "Width" getwid)
(vlax-put-property myobj "Justify" "0")
)
);;end if
);;end defun


(defun c:DEMO (/ oldpickbox oldcmd oldlayer vbobj gatherlayer newlayername *error*)
(setq oldcmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "._UNDO" "_End")
(command "._UNDO" "_Begin")
(setq oldlayer (getvar "clayer"))

(setq vbobj (vlax-ename->vla-object (car (_entsel "pick object for layer"))))
(setq gatherlayer (vlax-get-property vbobj "layer"))
;(setq gatherlayer (vla-get-layer vbobj))
(setq newlayername (strcat gatherlayer "-DEMO"));add -demo
(if (not (tblsearch "layer" newlayername))
(command "-layer" "make" newlayername "color" "red" newlayername "lt" "hidden2" newlayername "");create layer
(princ "layer exist")
)

(setq ss (ssget (list (cons 8 gatherlayer))))
(repeat (setq x (sslength ss))
(setq vbobj (vlax-ename->vla-object (ssname ss (setq x (- x 1)))))
(vlax-put-property vbobj "layer" newlayername);;;changes layer
(setq typ (vlax-get-property vbobj "Objectname"))
(princ (strcat "\n" typ " on layer " gatherlayer " moved to " newlayername " layer"))
(if (= typ "AecDbWall");;wall
(changestylename vbobj "tbr" (vlax-get-property vbobj "Width")) ;Call the Changestylename Function
)
);end repeat

(command "regen")
(setvar "clayer" oldlayer)
;;-----------------------------error
(setq *error* nil)
;;-----------------------------error
(command "._UNDO" "_End")
(setvar "cmdecho" oldcmd)
(princ)
);;

(c:demo)

[DC-MWA]

I tried it. It sets the layer current to layername-DEMO but then crashes and doesnt change the object selected.

message "; error: bad argument type: lselsetp nil"

[DC-MWA]

I need each object selected to be put on a layer the same as the layer they exist on with "-DEMO"

So objects on "A-CASE" would end up on layer "A-CASE-DEMO"

Walls would end up on A-WALL-DEMO and the wall style would be changed to TBR as well as the width being matched.

[Kent1Cooper]

Here's a peculiarity for you, that can greatly simplify  such an operation:

If you use entity data's 8-code Layer-name entry to assign a Layer to an entity, if the Layer doesn't already exist, it creates it in the process!  So you can build a new Layer name and give it to an entity with (subst)/(entmod) operations on its entity data list, without  making the Layer first or checking whether it exists!  [This is not  true when doing it with (vla-put-Layer) or the CHPROP command, which will fail if the Layer doesn't exist.]

After doing that to a selection set's worth of things, putting them on Layers whose names add -DEMO to the name of their original Layer, you can then simply assign the color and linetype to all  Layers whose names end in -DEMO, all at once, whether they already existed yet or are newly-created ones [the latter will initially have had default color 7 and CONTINUOUS linetype].

Try this [just for the -DEMO Layer-name transfer, not including the wall-style aspect]:

(defun C:DEMOLT ; = DEMOlition Layer Transfer
  (/ ss n edata lay)
  (if (setq ss (ssget "_:L")); anything not on locked Layer(s)
    (progn ; then
      (repeat (setq n (sslength ss))
        (setq edata (entget (ssname ss (setq n (1- n)))))
        (if (not (wcmatch (strcase (setq lay (cdr (assoc 8 edata)))) "*-DEMO"))
          ; not already on a Layer ending in it [in any case combination]
          (entmod (subst (cons 8 (strcat lay "-DEMO")) (assoc 8 edata) edata))
           ; replace its Layer name with -DEMO added, whether or not that Layer exists
        ); if
      ); repeat
      (command "_.layer" "_color" 1 "*-DEMO" "_ltype" "HIDDEN2" "*-DEMO" "")
        ; assign those properties to all Layers whose names end in -DEMO
    ); progn
  ); if
  (princ)
); defun

You can even include things already  on -DEMO Layers in the selection, and it won't add a redundant -DEMO to their names [though if any of their Layers don't already have that color and linetype, it will "fix" that about them].

That's in simplest terms -- you can add *error* handling, command-echo suppression, Undo begin-end wrapping, etc.

[DC-MWA]

Thank you. That works perfect for standard objects.

The reason this thing got so complicated, is I'm dealing with AEC walls as well.

If a wall is selected i need to extract data from the wall selected and then modify the wall as well as change the layer.

So without making your beautifully simple routine a mess.... How do I achieve this?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if (= typ "AecDbWall");;wall
(progn
(setq getwid (vlax-get-property vbobj "Width"))
(defun changeStylename (myobj newstylename)
(if (vlax-property-available-p myobj "stylename" t)
(progn 
(princ (strcat "\nWall style \"" (vlax-get-property myobj "stylename") "\" changed to \"TBR\""))
(vlax-put-property myobj "stylename" newstylename);set new wall style
(vlax-put-property myobj "Width" getwid);set width taken from selected wall
(vlax-put-property myobj "Justify" "0");set justification taken from selected wall
)
);;end if

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

[dlanorh]

Try this. I've removed un-needed variables, and it checks it also checks if the linetype "hidden2" is loaded, and alerts if not. It uses standard ssget and you cannot select anything on a locked layer.

Sorry but i haven't tested as I don't currently have access to AutoCAD.

;;DEMOLITION TOOLS FOR MWA
(vl-load-com)

(defun c:DEMO (/ *error* sv_lst sv_vals c_doc c_lyrs p_msg ss cnt vbobj n_lyr l_obj w)

  (defun *error* ( msg )
    (princ "\nDone Demolishing items.")
    (mapcar 'setvar sv_lst sv_vals)
    (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
    (princ)
  );end_defun *error*

  (setq sv_lst (list 'cmdecho 'clayer)
        sv_vals (mapcar 'getvar sv_lst)
        c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_lyrs (vla-get-layers c_doc)
  );end_setq
  
  (cond ( (/= (getvar 'cmdecho) 0) (setvar 'cmdecho 0)))

  (cond ( (tblobjname "ltype" "hidden2")
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
  
          (setq p_msg "\nSelect objects to Demolish <Return to exit> : ")
          (prompt p_msg)
          (while (setq ss (ssget ":L"))
            (cond (ss
                    (repeat (setq cnt (sslength ss))
                      (grtext -1 "**DEMOLISH MODE**")
                      (setq vbobj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt))))
                            vb_lyr (vlax-get-property vbobj 'layer)
                            n_lyr (strcat vb_lyr "-DEMO")
                      );end_setq
                      (cond ( (not (tblobjname "layers" n_lyr))
                              (setq l_obj (vla-add c_lyrs n_lyr))
                              (mapcar '(lambda (x y) (vlax-put-property l_obj x y)) (list 'color 'linetype) (list 1 "hidden2"))
                            )
                      );end_cond
                      (vlax-put-property vbobj 'layer n_lyr)
                      (cond ( (= (vlax-get-property vbobj 'objectname) "AecDbWall")
                              (setq w (vlax-get-property vbobj 'width))
                              (cond ( (vlax-property-available-p vbobj 'stylename t)
                                      (princ (strcat "\nWall style \"" (vlax-get-property vbobj 'stylename) "\" changed to \"TBR\""))
                                      (mapcar '(lambda (x y) (vlax-put-property vbobj x y)) (list 'stylename 'width 'justify) (list "tbr" w "0"))
                                    )  
                              );;end_cond
                            )
                      );end_cond
                    );end_repeat
                  )
            );end_cond
            (prompt p_msg)
          );end_while
        )
        (t (alert "Linetype HIDDEN2 NOT loaded in drawing\nExiting.."))
  );end_cond      
  (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
  (mapcar 'setvar sv_lst sv_vals)
  (grtext -1 "**DEMOLISH MODE ENDED**")
  (princ)
);end_defun

[DC-MWA]

It crashes, and fast.

[dlanorh]

Sorry forgot to remove a debug line. Have amended the above, try it again.

[DC-MWA]

It gets the layer right and shows message correct "Wall style "3.5 wall" changed to "TBR""

but the style, justification and width of the wall is unchanged.

[dlanorh · Accepted solution]

 (cond ( (vlax-property-available-p vbobj 'stylename t)
              (princ (strcat "\nWall style \"" (vlax-get-property vbobj 'stylename) "\" changed to \"TBR\""))
              (mapcar '(lambda (x y) (vlax-put-property vbobj x y)) (list 'stylename 'width 'justify) (list "tbr" w "0"))
                                    )  
                              );;end_cond

Error spotted. Wrong variable name correct name is in red. I have amended the original code above (post 7)

[DC-MWA]

This seems to be the ticket.

I'm going to test on one of the projects I have going....

I'll be right back.

[ronjonp]

Does not do AEC walls but here's a quick mod of one of my routines. It includes a filter in the selection set so you don't end up with 'LayerName-DEMO-DEMO' .. if you select the object twice.

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

[dlanorh]

Nice one Ron. I didn't consider selecting an object twice.

[Anonymous]

nice!  is the corrected version in post 7?

I could use this for some civil sites, not as complicated as architecture buildings

[DC-MWA]

Thank you. This does the trick. My team is very pleased.

I truly appreciate your time and effort on this.

[ronjonp]

---

@dlanorh wrote:

Nice one Ron. I didn't consider selecting an object twice.

---

I created a mess many moons ago because I had not thought about it ; / Cheers!

[dlanorh]

@DC-MWA  Please find attached an updated version of this lisp to incorporate @ronjonp point of filtering objects already on demo layers.

[DC-MWA]

This is awesome!!

Thank you and @rperez 100 times better than I could have ever wished for.

At this very moment, 2 drafters are going crazy with the demolition on two large projects.

Again... AWESOME!!