Need help with a lisp please

hi peeps.

have a lisp from autodesk i have already modified slightly, what is does now is deletes duplacated text strings.

what i need one of you fine folk to do is instead of deleting the duplacated text string i want to turn it red.

thanks in advance much apprecated.

(defun c:deldup1_txt( / ss ssdup ct len e eb

pt lay ang sty hgt str obj obj_list)

(princ "\nSelect text objects.") ;Select objects and filter all but block insert objects.

(setq ss (ssget (list (cons 0 "TEXT"))))

(if ss ;If any valid objects were selected.

(progn

(princ "\nBuilding list of objects.")

(setq ssdup (ssadd)) ;Initialize new selection set to hold objects to delete

(setq len (sslength ss)) ;Find out how many objects were selected.

(setq ct 0)

(while (

(setq e (ssname ss ct)) ;Get an object name

(setq eb (entget e)) ;Get the entity list from the object name

(setq ct (+ ct 1)) ;Increment index into selection set

(setq str (cdr (assoc 1 eb))) ;Access object's text string

;Make list of object properties

(setq obj (list pt lay ang sty hgt str))

(if (not (member obj obj_list)) ;If these properties are not already in list

(setq obj_list (cons obj obj_list)) ;Add them to the list

(ssadd e ssdup) ;Else add object to selection set to delete

) ;End if

) ;End of while loop

(if (> (sslength ssdup) 0) ;If there are any objects in the selection set to delete

(progn

(princ "\nDeleting duplicate objects.")

(setq len (sslength ssdup)) ;Find out how many many objects to delete.

(setq ct 0)

(while (

(setq e (ssname ssdup ct)) ;Get object name

(setq ct (+ ct 1)) ;Increment index into selection set

(entdel e) ;Delete duplicate object

) ;End of while loop

(princ ;Print the number of objects deleted to command line

(strcat "\nDeleted "

(itoa len)

" duplicate objects."

))

) ;End progn

(princ "\nNo duplicates found.") ;Else no there were no duplicates to delete.

) ;End if

) ;End progn

(princ "\nNo text objects selected.") ;Else there were no valid objects selected

) ;End if

(princ)

)

Ahem. Code Posting Guidelines.

new to the site bud?

Yep I noticed, which is why I pointed you in the right direction without the threat of a stick

Please check if this is what you were looking for (changes in red):

(defun c:deldup1_txt  (/ ss ssdup ct len e eb pt lay ang sty hgt str obj obj_list)
(princ "\nSelect text objects.")       ;Select objects and filter all but block insert objects.
(setq ss (ssget (list (cons 0 "TEXT"))))
(if ss                                 ;If any valid objects were selected.
 (progn
  (princ "\nBuilding list of objects.")
  (setq ssdup (ssadd))                 ;Initialize new selection set to hold objects to delete
  (setq len (sslength ss))             ;Find out how many objects were selected. 
  (setq ct 0)
  (while (< ct len)                    ;Loop through selected objects
   (setq e (ssname ss ct))             ;Get an object name
   (setq eb (entget e))                ;Get the entity list from the object name
   (setq ct (+ ct 1))                  ;Increment index into selection set
   (setq str (cdr (assoc 1 eb)))       ;Access object's text string
                                       ;Make list of object properties
   (setq obj (list pt lay ang sty hgt str))
   (if (not (member obj obj_list))     ;If these properties are not already in list
    (setq obj_list (cons obj obj_list)) ;Add them to the list
    (ssadd e ssdup)                    ;Else add object to selection set to delete
    )                                  ;End if
   )                                   ;End of while loop
  (if (> (sslength ssdup) 0)           ;If there are any objects in the selection set to delete
   (progn
    [color=red](princ "\n[color=red]Marking [/color]duplicate objects.")
[/color]    (setq len (sslength ssdup))        ;Find out how many many objects to delete. 
    (setq ct 0)
    (while (< ct len)                  ;Loop through objects and delete.
     (setq e (ssname ssdup ct))        ;Get object name
     (setq ct (+ ct 1))                ;Increment index into selection set
[color=red];      (entdel e)                        ;Delete duplicate object[/color]
[color=red]     (command "_CHPROP" e "" "_C" 1 "")[/color]
     )                                 ;End of while loop
    (princ                             ;Print the number of objects deleted to command line 
[color=red]     (strcat "\n"[/color]
[color=red]             (itoa len)[/color]
[color=red]             " duplicate objects colored in RED."[/color]
[color=red]             ))[/color]
    )                                  ;End progn
   (princ "\nNo duplicates found.")    ;Else no there were no duplicates to delete.
   )                                   ;End if
  )                                    ;End progn
 (princ "\nNo text objects selected.") ;Else there were no valid objects selected
 )                                     ;End if
(princ)
)

Regards,

Mircea

works a treat thank you very much

You're welcomed!

Also, please edit your first post to add those code brackets, it will look better.

Regards,

Mircea

FWIW

(defun C:dupsamestr  (/ ss e lst str)
     (vl-load-com)
     (if (setq lst nil
               ss  (ssget ":L" '((0 . "TEXT"))))
           (repeat (setq i (sslength ss))
                 (setq e (ssname ss 0))
                 (if (setq f (member (setq str  (cdr (assoc
                                                           1
                                                           (entget e))))
                                     lst))
                       (vla-put-color (vlax-ename->vla-object e) 1)
                       (setq lst (cons str lst))
                       )
                 (ssdel e ss)
                 )
           )
     (princ (strcat "\nFound "
                    (itoa (- i (length lst) ))
                    " Duplicate String"))
     (princ)
     )

Nice solution pBe.

One comment if you don't mind; I'm afraid that there is an issue in your duplicate counter:

(itoa (- i (length lst) [color=red](length lst)[/color]))

Regards,

Mircea

Nice solution pBe.

One comment if you don't mind; I'm afraid that there is an issue in your duplicate counter:

 

(itoa (- i (length lst) [color=red](length lst)[/color]))

 

Regards,

Mircea

[code update]

Good catch Mircea. A case of too many copy & paste on my part.

Cheers

One more variation...

(defun c:DupTxt ( / a e i l s x )
   (if (setq s (ssget "_:L" '((0 . "TEXT"))))
       (progn
           (repeat (setq i (sslength s))
               (setq e (entget (ssname s (setq i (1- i))))
                     x (cdr (assoc 1 e))
               )
               (if (setq a (assoc x l))
                   (setq l (subst (cons x (1+ (cdr a))) a l)
                         e (entmod (append e '((62 . 1))))
                   )
                   (setq l (cons (cons x 1) l))
               )
           )
           (foreach x l (if (< 1 (cdr x)) (print x)))
       )
   )
   (princ)
)

Lee Mac,

May be important to isolate and delete duplicate entities, it would be interesting to assign them to its own layer.

shakey230,

Please edit your post to include Code Tags.