Please help add an option to this lisp.

I have been using this lisp to copy an entity multiple times, I would like to add an option that when an entity is copied, it automatically has its color changed to a different one so I can see the difference (if the original is red then the next one would have color +1 to be yellow and the next one would be green....)

Thank you very much for help.

(defun c:C ()

(defun DR_ERR (S) ; If an error (such as CTRL-C) occurs

(if (/= S "Function cancelled") ; while this command is active...

(if (= S "quit / exit abort")

(princ)

(princ (strcat "\nError: " S))

);end if

);end if

(if DR_OER ;If an old error routine exists

(setq *error* DR_OER) ;then, reset it

);end if

(if (not BASEPT) ;if an initial displacement was used

(foreach x SSELIST (redraw X 4));unhighlight the last selection set

)

(setvar "cmdecho" 1) ;reset command echo upon error

(princ)

);end error defun

;**** Set our new error handler ****

(if (not *DEBUG*)

(if *error*

(setq DR_OER *error* *error* DR_ERR)

(setq *error* DR_ERR)

);end if

);end if

;**** BEGIN MAIN FUNCTION ****

(if (setq EMARK (entlast))

(while (setq B (entnext EMARK))

(setq EMARK B)

)

)

(setq SS (ssget))

(setvar "cmdecho" 0)

(prompt "\nBase point or Displacement: ")

(command "copy" SS "" pause)

(setq BASEPT (getvar "lastpoint"))

(prompt "\nCopy point: ")

(command pause)

(if (equal BASEPT (setq LASTPT (getvar "lastpoint")))

(progn (setq REFPT LASTPT)

(setq BASEPT nil)

)

)

(if BASEPT

(while (entnext EMARK) ;while there are new entities

(setq SSOLD SS)

(setq SS (ssadd)) ;reset SS

(while (entnext EMARK) ;while there are new entities

(setq EMARK (entnext EMARK))

(ssadd EMARK SS) ;add them to new SS

)

(if (equal BASEPT (setq LASTPT (getvar "lastpoint")))

(progn (command "erase" SS "")

(command "copy" SSOLD "" REFPT "")

(setvar "lastpoint" (polar BASEPT ANGLPT DISTPT))

)

(progn (setq ANGLPT (angle BASEPT LASTPT))

(setq DISTPT (distance BASEPT LASTPT))

(setq REFPT (polar '(0.0 0.0 0.0) ANGLPT DISTPT))

(setq BASEPT LASTPT) ;increment basepoint

(prompt (strcat "\nCopy point : "))

(command "copy" SS "" BASEPT pause)

)

)

);end while

(ssget "P")

(setq REFPT (getpoint (strcat "\nDisplacement : ")))

(if (not REFPT)

(setq REFPT (getvar "lastpoint"))

)

(command "copy" SS "" REFPT "")

);end while

);end if

(setvar "cmdecho" 1)

(princ)

);end defun

(princ)

What happens if you select multiple objects - for copying - and they all are different colors?

I rarely use more than one entity therefore I forgot to mentioned. If it could be modified to copy just one, I would be happy.

Replace (ssget) with (car (entsel)) for single selection.

You could up the color with a subroutine like the following and use chprop, change, entmod, vla-put-color to set the color.

(defun _colorUp (entity / num)
 (if (eq (type entity) 'ENAME)
   (if (eq 255
           (setq num (abs
                       (cond ((cdr (assoc 62 (entget entity))))
                             ((cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget entity)))))))
                       )
                     )
           )
       )
     1
     (1+ num)
   )
 )
)

I changed (ssget) with (car (entsel)) but it selects the last entity drawn instead of let me select the one I wanted

Giv me a hint which line should I put the subroutine.

(this is way above my head)

Thanks

I changed (ssget) with (car (entsel)) but it selects the last entity drawn instead of let me select the one I wanted

Giv me a hint which line should I put the subroutine.

(this is way above my head)

Thanks

example using Alanjt sub

 
(defun c:cc  ( / obj pt1 pt2 )
(defun _colorUp (entity / num)
(if (eq (type entity) 'ENAME)
 (if (eq 255
         (setq
           num
            (abs
              (cond
                ((cdr (assoc 62 (entget entity))))
                ((cdr
                   (assoc
                     62
                     (tblsearch
                       "LAYER"
                       (cdr (assoc 8 (entget entity)))))))))))
   (setq num 1)
   (setq num (1+ num))))
(command "_chprop" entity "" "color" num "")
)
 (setq
   obj (entsel "\nSelect object to copy: ")
   pt1 (getpoint "\nPick base point:"))
 (while (setq pt2 (getpoint pt1 "\nNext point:"))
   (command "copy" obj "" pt1 pt2)
   (setq
     pt1 pt2
      obj (entlast))
(_colorUp obj)

   )
 )

Hope this helps

I got it to work now

Thank you pBe

Just for kicks...

(defun c:TEst (/ _colorUp obj lst pt color)

 (vl-load-com)

 (defun _colorUp (obj / color)
   (if (eq 255
           (if (vl-position (setq color (vla-get-color obj)) '(0 256))
             (setq color (cdr (assoc 62 (tblsearch "LAYER" (vla-get-layer obj)))))
             color
           )
       )
     1
     (1+ color)
   )
 )

 (if (and (setq obj (car (entsel "\nSelect object to copy: ")))
          (setq obj (vlax-ename->vla-object obj))
          (car (setq lst (list (getpoint "\nSpecify base point: "))))
     )
   (while (setq pt (if acet-ss-drag-move
                     (acet-ss-drag-move
                       (ssadd (vlax-vla-object->ename obj))
                       (car lst)
                       "\nSpecify next point: "
                       T
                     )
                     (getpoint (car lst) "\nSpecify next point: ")
                   )
          )
     (setq color (_colorUp obj))
     (vla-move (setq obj (vla-copy obj))
               (vlax-3d-point (trans (car lst) 1 0))
               (vlax-3d-point (trans (car (setq lst (cons pt lst))) 1 0))
     )
     (vla-put-color obj color)
   )
 )
 (princ)
)