Jump to content

Creating a LISP to use SELECTSIMILAR then COPYTOLAYER


rawnb33

Recommended Posts

At my job I often have to copy items that are populated by a separate program and assign them to a new layer. For this I usually use the SELECTSIMILAR command followed by the COPYTOLAYER to specify the layer. I'm very green when it comes to writing lisps and while I've given it the "old college try" I'm still unable to get it to work correctly. Below is the extremely wrong lisp that I've created. Thanks for any help you'd be able to provide me.

 

(DEFUN C:YAH()

 

(COMMAND "SELECTSIMILAR" PAUSE "")

 

(COMMAND "COPYTOLAYER" "CONFIXED" "0,0" "0,0" "")

 

(PRINC)

)

Link to comment
Share on other sites

Hi rawnb,

 

FYI, there is a forum here that is dedicated to lisp programming.

 

You didn't mention if you wanted to delete the original selection after copying.

Anyway, see if this works for you:

 

; SELECT SIMILAR & COPY TO LAYER

(defun c:YAH  ( / clay doc )
 (defun *error* (msg)
   (if	(and msg
     (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
) ;_ end of and
     (princ (strcat "\nError: " msg))
   ) ;_ end of if
   (if	clay
     (setvar 'clayer clay)
   )
   (if	doc
     (vla-endundomark doc)
   ) ;_ end of if
   (princ)
 ) ;_ end of defun
 
 (setq clay (getvar 'clayer))
 (if (not (tblsearch "LAYER" "CONFIXED")) ; if layer CONFIXED does not exist
   (command "-layer" "make" "CONFIXED" "color" "white" "" "") ;create layer CONFIXED
   (command "-layer" "thaw" "CONFIXED" "on" "CONFIXED" "") ;make sure layer is not frozen
 )
 (setvar 'clayer clay)

 (setq doc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark doc)
 (selsim)
 (command "_.copytolayer" "p" "" "CONFIXED" "0,0" "0,0")
 (vla-endundomark doc)
 (princ)
) ;_ end of defun
(vl-load-com)


;;; Select Similar
;;; (based on a command found in a few versions of AutoCAD)
;;; written by Adam Wuellner 
;;; all rights released

;--------> MAIN ROUTINE
(defun selsim	(/ ss1 i ent filter_list type-layer filter sstemp)
 (if (not (setq ss1 (cadr (ssgetfirst))))
   (setq ss1 (ssget))
 ) ;_ end of if
 (setq	i 0
filter_list
 '()
 ) ;_ end of setq
 (repeat (sslength ss1)
   (setq ent (entget (ssname ss1 i))
  i   (1+ i)
   ) ;_ end of setq
   (setq type-layer (list (assoc 0 ent) (assoc 8 ent)))
   (if	(not (member type-layer filter_list))
     (setq filter_list (cons type-layer filter_list))
   ) ;_ end of if
 ) ;_ end of repeat
 (foreach filter filter_list
   (princ (strcat "selecting all "
	   (cdar filter)
	   " entities on layer "
	   (cdadr filter)
	   "...\n"
   ) ;_ end of strcat
   ) ;_ end of princ
   (setq sstemp (ssget "X" filter))
   (setq ss1	 (ss:union ss1 sstemp)
  sstemp nil
   ) ;_ end of setq
 ) ;_ end of foreach
 (sssetfirst nil ss1)
 (princ)
) ;_ end of defun


;--------> UNION
(defun ss:union	(ss1 ss2 / ename ss-smaller ss-larger c)
 (cond	((and ss1 ss2)
 (setq c 0)
 (if (< (sslength ss1) (sslength ss2))
   (setq ss-smaller
	  ss1
	 ss-larger ss2
   ) ;_ end of setq
   (setq ss-larger ss1
	 ss-smaller ss2
   ) ;_ end of setq
 ) ;_ end of if
 (while	(< c (sslength ss-smaller))
   (setq ename (ssname ss-smaller c)
	 c     (1+ c)
   ) ;_ end of setq
   (if (not (ssmemb ename ss-larger))
     (ssadd ename ss-larger)
   ) ;_ end of if
 ) ;_ end of while
 ss-larger
)
(ss1 ss1)
(ss2 ss2)
(t nil)
 ) ;_ end of cond
) ;_ end of defun

Edited by PDuMont
Link to comment
Share on other sites

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.

×
×
  • Create New...