Locate & highlight specific attributes.

[Manila Wolf]

Good day to all.

 

I am wondering if any posters here can help. I have to say in advance that my lisp skills are very limited indeed.

 

I am aware of the built in AutoCAD find command and I can find numerous lisps that can find and zoom to specific text, but I am looking for something a little more dedicated to a specific task.

 

The following lisp "LocatePart.lsp" helps me to find and highlight all instances of a specific attribute tag (Tag name "PART") within a specific block (Block name "PartTag"), based on a user input text string.

The lisp draws a donut at each of the relevant attribute text strings found.

 

This works fine, but it would be much easier to see the results if instead of drawing a donut at each found point, a line was drawn from each of the found attributes to an origin point 0,0,0

 

Without lisp knowledge, I am not sure if this is quick and easy to do.

 

(defun c:LocatePart (/ usrprtnm prtfound enttyp blknm lccosnapm lccentcolr) 
(setq lccosnapm  (getvar "OSMODE"))
;(setq lccentcolr (getvar "CECOLOR"))
;(setvar "CECOLOR" "1")
(setvar "OSMODE" 0)
(setvar "cmdecho" 0)
(getuserprtnum)
(findprtnm)
;(setvar "CECOLOR" lccentcolr)
(setvar "OSMODE" lccosnapm)
(prin1)
;(setvar "cmdecho" 1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; GETUSERPRTNUM - Get Part number from user
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun getuserprtnum ()
 (setq usrprtnm (getstring "\nEnter Partnumber to locate : "))
 (while (= "" usrprtnm)
     (setq usrprtnm (getstring "\nIncorrect input, 
                     enter again (ctrl-c to exit) : "))
 )     
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;  FINDATT - Find attributes in drawing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun findprtnm ()
(setq ctprblk 0)	;part assembly counter
(setq prtfound 0)	;reset search counter
(setq e (entnext))
 (progn (prompt "\nSeraching unit assembly ... ")
  (while e
    (setq enttyp (cdr (assoc 0 (entget e))))
    (setq blknm (cdr (assoc 2 (entget e))))
     (if
       (and
         (equal enttyp "INSERT")
  (equal blknm "PartTag")
         ;(equal (cdr (assoc 66 (entget e))) 1)
       ) ;and
        (updprtnmprop e)
     ) ;if
      (setq e (entnext e))
   ) ;while
 ) ;progn
 ;report search status
 (cond ((= prtfound 0)
        (princ (strcase usrprtnm))
        (princ " NOT found !")
        (prin1))
       ((/= prtfound 0)
        (princ prtfound)
        (princ " ")
        (princ (strcase usrprtnm))
        (princ " found")
        (prin1))
 ) ;cond
 
) ;defun findprtnm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;  UPDPRTNMPROP - Compare Part number, change color if found
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun updprtnmprop (e / blkscle insertpt dndia nx ny dnpt)
  (setq blkscle (cdr (assoc 41 (entget e))))
  ;(princ blkscle)
  (setq insertpt (cdr (assoc 10 (entget e))))
  
  (while (not (equal (cdr (assoc 0 (entget e))) "SEQEND"))
      (if
        (and 
           (equal (cdr (assoc 0 (entget e))) "ATTRIB")
           (equal (cdr (assoc 2 (entget e))) "PART")
        ) ;and
                  (progn
                     (setq partnm (strcase (cdr (assoc 1 (entget e)))))
                     ;(princ partnm)
                     (if (= (strcase usrprtnm) (strcase partnm))
                       ;(princ "\nPart name : ")
	        ;(princ partnm)
                         (progn
                           ;(princ insertpt)
                           (setq dnind (* 1.0 (abs blkscle)))
                           (setq dndia (* 3.5 (abs blkscle)))
                           (setq ny (cadr insertpt))
                           (setq ofstx (* (abs blkscle) 6.5))
                           (setq nx (+ (car insertpt) ofstx))
                           ;(princ nx)
                           (setq dnpt (list nx ny))
		    ;(princ dndia)
		    (command "donut" 0  dndia dnpt "") 
                           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	            ;change color
		    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
                           ;(setq ed (entget e))
                           ;; 62 - color property
                           ;(setq ed (subst (cons 62 1) (assoc 62 ed) ed))
                           ;(entmod ed)
		    ;(entupd e)
			    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
		    ;; counter ++
		    (setq prtfound (+ prtfound 1))
		    ;(princ prtfound)
                          ) ;progn
                     )	;if											
                   ) ;progn
      ) ;if
      (setq e (entnext e))
  ) ;while
  
) ;defun updprtnmprop

 

I attach drawing "TagSystemExample.dwg" for reference.

 

I guess I am trying to achieve something similar to this lisp that finds blocks and draws lines to an origin point as found here: -

 

http://autocadtips.wordpress.com/2011/12/20/autolisp-find-blocks-mark-them/

 

Any help or suggestions would be appreciated.

TagSystemExample.dwg

[Lee Mac]

This should work for Text, MText or Attributes:

 

(defun c:myfind ( / ent enx inc sel str )
   (if (setq sel
           (ssget "_X"
               (list
                  '(-4 . "<OR")
                      '(0 . "TEXT,MTEXT")
                      '(-4 . "<AND") '(0 . "INSERT") '(66 . 1) '(-4 . "AND>")
                  '(-4 . "OR>")
                   (if (= 1 (getvar 'cvport))
                       (cons 410 (getvar 'ctab))
                      '(410 . "Model")
                   )
               )
           )
       )
       (if (/= "" (setq str (strcase (getstring t "\nFind What?: "))))
           (progn
               (repeat (setq inc (sslength sel))
                   (if (= "INSERT" (cdr (assoc 0 (setq enx (entget (setq ent (ssname sel (setq inc (1- inc)))))))))
                       (while (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (setq ent (entnext ent)))))))
                           (if (= str (strcase (cdr (assoc 1 (reverse enx)))))
                               (entmake (list '(0 . "LINE") (assoc 10 enx) '(11 0.0 0.0 0.0)))
                           )
                       )
                       (if (= str (strcase (cdr (assoc 1 enx))))
                           (entmake (list '(0 . "LINE") (assoc 10 enx) '(11 0.0 0.0 0.0)))
                       )
                   )
               )
           )
       )
       (princ "\nNo Text, MText or Attributes found in this Layout.")
   )
   (princ)
)

 

'Find' strings are case-insensitive.

[Manila Wolf]

Lee, you are amazing.

Exactly what I was looking for.

 

Not only your coding ability, but the way you are so willing to help people here is truly admirable.

 

Thank you.

[Lee Mac]

Thank you Manila Wolf, you already had most of the code to accomplish this, but I thought it better to provide a general all-purpose program; glad it helps.