Removing Suffix LISP Tweak!

[tmelancon]

Have a neat little LISP that removes prefix or suffix. Currently it is written to remove anything before or after a "dash" INCLUDING THE DASH. I need it to keep the dash. Thanks in advance.

 

;;
;; By Don Ireland
;;
;; Takes two arguments: A String to search for and a string to search in.
;; Usage: (charfind "ST" "TEST") ; This will return 3.
;;
;; Example: (if (> (setq pos (charfind "S" "TEST")) 0)(princ "Found the letter S at position: " . pos)(Princ "One or both search parameters was blank"))
;;
;; Return Values:
;; -1 = character not found within given string.
;; -2 = Search string is empty. (srch)
;; -4 = Test String is empty. (str)
;; -6 = Search String and Test String are both empty.
(defun strfind(srch str / pt pt2 cnt)
(setq cnt 0 pt 0 pt2 nil)
(if (EQ (strlen srch) 0) (setq pt -2))
(if (EQ (strlen str) 0) (setq pt (+ pt (- 0 4))))
(if (EQ pt 0)(setq pt -1))
(while (and (< pt 0) (> (strlen str) 0)(< cnt (strlen str)))
(if (eq srch (substr str (setq cnt (1+ cnt)) (strlen srch)))(setq pt cnt))
)
(setq pt2 pt)
)
(defun remTxt(ba)
(setq ent (ssget '(
(-4 . "<OR")
(0 . "TEXT")(0 . "MTEXT")(8 . "*DATA")
(-4 . "OR>")
))
)
(setq cnt -1)
(repeat (sslength ent)
(setq cent (entget (ssname ent (setq cnt (1+ cnt)))))
(setq cur (cdr(assoc 1 cent)))
(setq pos (strfind "-" cur))
(if (EQ ba 1)
(setq new (substr cur 1 (1- pos)))
(setq new (substr cur (1+ pos) (strlen cur)))
)
(setq cent(subst (cons 1 New) (cons 1 cur) cent))
(entmod cent)
)
)
(defun c:remA()
(remTxt 1)
)
(defun c:remB()
(remTxt 0)
)

[pkenewell]

if you want to do both the Prefix and the Suffix, change the following lines:

 

 

(if (EQ ba 1)
  (setq new (substr cur 1 (1- pos)))
  (setq new (substr cur (1+ pos) (strlen cur)))
)

 

 

to:

 

 

(if (EQ ba 1)
  (setq new (substr cur 1 pos))
  (setq new (substr cur pos (strlen cur)))
)

[Lee Mac]

Try the following:

(defun remtxt ( f / e i s x )
   (if (setq s (ssget "_:L" '((0 . "TEXT,MTEXT") (1 . "*`-*"))))
       (repeat (setq i (sslength s))
           (setq e (entget (ssname s (setq i (1- i))))
                 x (assoc 1 e)
           )
           (entmod (subst (cons 1 (f (cdr x) (1+ (vl-string-search "-" (cdr x))))) x e))
       )
   )
   (princ)
)
(defun c:rema nil (remtxt (lambda ( s p ) (substr s 1 p))))
(defun c:remb nil (remtxt (lambda ( s p ) (substr s p))))

[tmelancon]

Works really sweet.. I was on to something earlier, I removed the 1- but didnt remove the () that was associated with it. Also, two more things, I am getting lists showing up in the command line, I tried using CMDECHO and that didnt seem to work. Any ideas? Also the other thing I was curious about is how would I write for the SSGET to automatically get TEXT on DATA layer and perform this operation.. instead of user selected TEXT. Thanks in advance for your great knowledge!

 

I tried:

 

  (setq    ent (ssget "X" (LIST
            (CONS -4 "<OR")
            (CONS 0 "TEXT")
            (CONS 0 "MTEXT")
            (CONS 8 "*DATA")
            (CONS -4 "OR>")
           )
       )
 )

 

..nothing.

[tmelancon]

Hey guys thanks for chiming in really appreciate it. Lee I was able to get yours to work the way I needed it, so I guess I will be archiving the other one.

 

This is what worked:

 

(defun remtxt ( f / e i s x )
   (if (setq s (ssget [color=red]"X"[/color] '((0 . "TEXT,MTEXT") (1 . "*`-*") [color=red](8 . "*DATA,*HIGH")[/color])))
       (repeat (setq i (sslength s))
           (setq e (entget (ssname s (setq i (1- i))))
                 x (assoc 1 e)
           )
           (entmod (subst (cons 1 (f (cdr x) (1+ (vl-string-search "-" (cdr x))))) x e))
       )
   )
   (princ)
)
(defun c:rema nil (remtxt (lambda ( s p ) (substr s 1 p))))
(defun c:remb nil (remtxt (lambda ( s p ) (substr s p))))

[pkenewell]

LOL Lee Beat me to the Punch (along with the most efficient code), but here's my version anyway FWIW with complete error handling:

 

 

(defun RemTxt (ps / _Massoc cnt en Remtxt_error ss sp st)
  (vl-load-com)
  ;; Error Handling
  (defun Remtxt_error (msg)
   (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*quit*,*exit*"))
     (princ (strcat "\nError: " msg "\n"))
       (princ "\nProgram Aborted.\n")
     )
     (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
     (and err:bak (setq *error* err:bak))
  )
  ;; Nested Function to get Multiple repeating DXF codes.
  (defun _Massoc (el dxf)
     (vl-remove-if 'null
        (mapcar (function (lambda (x)(if (= (car x) dxf) x nil))) el)
     )
  )
  (setq err:bak *error* *error* Remtxt_error)
  (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (princ "\nSelect TEXT or MTEXT: ")
  (if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
     (repeat (sslength ss)
        ; Get the Entity Name
        (setq en (entget (ssname ss (setq cnt (if cnt (1+ cnt) 0)))))
        ; Check for long strings
        (if (assoc 3 en)
           (setq st
              (strcat
                 (apply 'strcat (mapcar 'cdr (_Massoc en 3)))
                 (cdr (assoc 1 en))
              )
           )
           (setq st (cdr (assoc 1 en)))
        )
        ;; Get the "-" char. pos.
        (setq sp (vl-string-position 45 st))
        ;; If a dash exists, truncate based on the flag.
        (if sp
           (setq ns (if ps (substr st 1 (1+ sp)) (substr st (1+ sp))))
           (princ "\nNo Dashes found in String.")
        )
        ;; Update the entity.
        (setq en (subst (cons 1 ns) (assoc 1 en) en))
        (entmod en)
     )
  )
  (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (setq *error* err:bak)
  (princ)
)

(defun c:remA()(RemTxt T))
(defun c:remB()(RemTxt nil))

[pkenewell]

Here is another version using Yours and Lee's Filtering and using ActiveX to change the Text String (a bit less code from my previous):

 

 

(defun RemTxt (ps / _Massoc cnt en ss sp st)
  (vl-load-com)
  ;; Error Handling
  (defun Remtxt_error (msg)
   (if (not (wcmatch (strcase msg T) "*break*,*cancel*,*quit*,*exit*"))
     (princ (strcat "\nError: " msg "\n"))
       (princ "\nProgram Aborted.\n")
     )
     (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
     (and err:bak (setq *error* err:bak))
  )
  (setq err:bak *error* *error* Remtxt_error)
  (vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (princ "\nSelect TEXT or MTEXT: ")
  (if (setq ss (ssget "X" '((0 . "TEXT,MTEXT")(1 . "*`-*")(8 . "*DATA,*HIGH"))))
     (repeat (sslength ss)
        ; Get the Entity ID
        (setq en (ssname ss (setq cnt (if cnt (1+ cnt) 0)))
              st (vla-get-TextString (vlax-ename->vla-object en))
              sp (vl-string-position 45 st)
              ns (if ps (substr st 1 (1+ sp)) (substr st (1+ sp)))
        )
        ;; Update the entity.
        (vla-put-TextString (vlax-ename->vla-object en) ns)
     )
  )
  (vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))
  (setq *error* err:bak)
  (princ)
)

(defun c:remA()(RemTxt T))
(defun c:remB()(RemTxt nil))

Edited June 6, 2016 by pkenewell