Wow, thanks Gile, very nice..
Pockets, here is the revised/repaired LISP.
Distroy the other copy!
; The following program is written as an aid to finding occurances of
; a string within an Autocad drawing. Strings which are part of
; primary text entities, attributes, and blocks (one level deep) are found.
;
; The user is prompted to enter a target string, pick a base point and
; indicate whether blocks are to be searched. The target string is the
; string of text you want to find. Using upper or lower case does not
; affect the results. The program uses the base point you select to draw
; lines to the insertion point of all text entities which contain the
; target string.
;
;
;
(defun c:fndtxt (/ p1 ss1 ss2 ss3 ss1len ss2len ss3len index mat target
test p2 name atfl ent blknm blkstuf base ename tbase
count en2 bname ip scale rang i ques transl match
)
(defun transl (base ip scale rang tbase / dist ang xr yr pt2)
(setq dist (* (distance base tbase) scale)
ang (angle base tbase)
xr (+ (car ip) (* dist (cos (+ ang rang))))
yr (+ (cadr ip) (* dist (sin (+ ang rang))))
pt2 (list xr yr)
)
)
(defun match (target test / tstlen tarlen dif z ind temp )
(setq tstlen (strlen test)
tarlen (strlen target)
dif (+ (- tstlen tarlen) 1)
z 1
ind 0
v 'Q
)
(if (> dif 0)
(repeat dif
(while z
(setq ind (+ ind 1)
temp (substr test ind tarlen)
)
(if (= temp target)
(setq v 'T
z nil
)
)
(if (>= ind tstlen)(setq z nil))
)
)
)
(eval v)
)
(graphscr)
(setvar "cmdecho" 0)
(setq target (strcase (getstring T "\nEnter target string: "))
p1 (getpoint "\nPick base point for marks ")
ques (strcase (substr (getstring "\nDo you wish to search blocks too? <Y>: ") 1 1))
)
(if (= ques "")(setq ques "Y"))
(prompt "\nCreating selection sets -Please wait ")
(setq ss1 (ssget "x" '((0 . "TEXT")))
ss1len (if (/= ss1 nil)(sslength ss1)(eval 0))
index -1
mat 0
)
(prompt (strcat "\nNumber of text entities in drawing: " (itoa ss1len)))
(prompt (strcat "\n Entities checked Matches found for <"
target ">"
)
)
(terpri)
(repeat ss1len
(prompt (strcat "\r " (itoa (+ index 2))
" "(itoa mat)
)
)
(setq index (+ index 1)
test (strcase (cdr (assoc 1 (entget (ssname ss1 index)))))
)
(if (match target test)
(progn
(setq p2 (cdr (assoc 10 (entget (ssname ss1 index))))
mat (+ mat 1)
)
(command "line" p1 p2 "")
)
)
)
(if (= ques "Y")
(progn
(prompt "\nChecking blocks for attributes: ")
(setq ss2 (ssget "x" '((0 . "INSERT")))
ss2len (if (/= ss2 nil)(sslength ss2)(eval 0))
)
(prompt (strcat "\n Blocks checked Matches found for <"
target ">"
)
)
(terpri)
(setq index -1)
(repeat ss2len
(prompt (strcat "\r " (itoa (+ index 2))
" "(itoa mat)
)
)
(setq index (+ index 1)
name (ssname ss2 index)
atfl (cdr (assoc 66 (setq ent (entget name))))
)
(if (= atfl 1)
(while (/= (cdr (assoc 0 ent)) "SEQEND")
(if (= (cdr (assoc 0 ent)) "ATTRIB")
(if (match target (strcase (cdr (assoc 1 ent))))
(progn
(command "line" p1 (cdr (assoc 10 ent)) "")
(setq mat (+ mat 1))
(prompt (strcat "\r " (itoa (+ index 2))
" "(itoa mat)
)
)
)
)
)
(setq ent (entget (setq name (entnext name))))
)
)
)
(setq index -1)
(repeat ss2len
(setq index (+ index 1)
name (ssname ss2 index)
blknm (cdr (assoc 2 (entget name)))
)
(setq i (substr blknm 1 1))
(if (and (not (member blknm ss3)) (/= i "*"))(setq ss3 (cons blknm ss3)))
)
(prompt (strcat "\nChecking " (itoa (length ss3)) " blocks for imbedded text: " ))
(prompt (strcat "\nBlock Entities checked Matches found for <"
target ">"
)
)
(terpri)
(setq index -1)
(repeat (length ss3)
(setq index (+ index 1)
blknm (nth index ss3)
blkstuf (tblsearch "block" blknm)
base (cdr (assoc 10 blkstuf))
ename (cdr (assoc -2 blkstuf))
)
(setq i -1)
(while ename
(setq i (+ i 1))
(prompt (strcat "\r" blknm " " (itoa i) " "(itoa mat))
)
(setq ent (entget ename))
(if (= (cdr (assoc 0 ent)) "TEXT")
(progn
(setq test (cdr (assoc 1 ent)))
(if (match target test)
(progn
(setq tbase (cdr (assoc 10 ent))
count -1
)
(repeat ss2len
(setq count (+ count 1)
en2 (ssname ss2 count)
bname (cdr (assoc 2 (entget en2)))
)
(if (= bname blknm)
(progn
(setq ip (cdr (assoc 10 (entget en2)))
scale (cdr (assoc 41 (entget en2)))
rang (cdr (assoc 50 (entget en2)))
)
(command "line" p1 (transl base ip scale rang tbase) "")
(setq mat (+ mat 1))
(prompt (strcat "\r" blknm " "(itoa i)
" "(itoa mat)
)
)
)
)
)
)
)
)
)
(setq ename (entnext ename))
)
)
)
)
(princ)
)