Code:
(if (not (member "doslib2k.arx" (arx))) ;_ ist doslib2K geladen?
(progn
(setq FND (findfile "doslib2k.arx")) ;_ nein? Dann finde es
(if FND ;_ wenn gefunden, lade es
(if (eq (arxload FND "err") "err") ;_ Fehler beim laden?
(alert
(strcat "\nKonnte \"doslib2k.arx\" finden, aber nicht laden."
"\nFunktionen nicht ausführbar."
) ;_ end of strcat
) ;_ end of alert
) ;_ end of if
(alert
(strcat
"\nKonnte \"doslib2k.arx\" nicht finden.\nFunktionen nicht ausführbar."
"\nDownload der \"doslib2k.arx\" von \"www.mcneel.com\""
"\nKopiere bitte danach die \"DOS_LIB\" Daten in den Acad-Suchpfad."
) ;_ end of strcat
) ;_ end of alert
) ;_ end if
) ;_ end progn
(princ)
)(defun C:ATT-SEARCH
(/ BLOCKLST BNAMES SEARCHATTNAME SEARCHWHAT SGET SSRETVAL X)
(setq SEARCHATTNAME (getstring
"\nName des Attributs in dem der Text gesucht werden soll?: "
) ;_ end getstring
SEARCHWHAT (getstring "\nZu suchender Text? (Wildcards-möglich): ")
) ;_ end setq
(ATTSEARCH ATTNAMES SEARCHFOR)
(princ)
) ;_ end defun
;;; Advanced Att-Search
(defun C:AATT-SEARCH (/ ATTNAMES SEARCHFOR)
(initget "Manuell")
(setq ATTNAMES
(entsel
"\nAttributnamen ermitteln, Block wählen oder [Manuell]: "
) ;_ end entsel
) ;_ end setq
(if (not ATTNAMES)
(alert "\nKein Block gewählt, Funktionsende !")
(if (eq ATTNAMES "Manuell")
(setq ATTNAMES
(dos_getstring
"Suche in Attribut-Feld..."
"Attribut-Feld-Namen eingeben:"
"Groß/Kleinschreibung ist egal!"
) ;_ end dos_getstring
) ;_ end getstring
(if (not (setq ATTNAMES (ATTRIBUTES? (car ATTNAMES))))
(alert
"\nGewählter Block enthält keine Attribute, Funktionsende !"
) ;_ end alert
(if (not (setq ATTNAMES
(dos_listbox
"Suche in welchem Attribut-Feld?"
"Einen Attributnamen wählen:"
(mapcar '(lambda (X) (car X)) ATTNAMES)
) ;_ end dos_listbox
) ;_ end setq
) ;_ end not
(alert "\nNichts gewählt oder Abbruch, Funktionsende !")
(if (not (setq SEARCHFOR (dos_getstring
"Zu suchender Text..."
"Zu suchenden Text eingeben:"
"(wcmatch)-Wildcards-möglich !"
) ;_ end dos_getstring
) ;_ end setq
) ;_ end not
(alert "Keine Eingabe für Suchtext, Funktionsende !")
) ;_ end if
) ;_ end if
) ;_ end if
) ;_ end if
) ;_ end if
(if (and ATTNAMES SEARCHFOR)
(ATTSEARCH ATTNAMES SEARCHFOR)
) ;_ end if
(princ)
) ;_ end defun
(defun ATTSEARCH
(SEARCHATTNAME SEARCHWHAT / BLOCKLST BNAMES SGET SSRETVAL X)
(if (not (and SEARCHATTNAME SEARCHWHAT))
(alert "Unzureichende Angaben..., Funktionsende !")
(progn
(setq SEARCHATTNAME (vl-string-trim " " (strcase SEARCHATTNAME))
SEARCHWHAT (vl-string-trim " " SEARCHWHAT)
) ;_ end setq
(if (not
(setq BLOCKLST (LISTBLOCKS-BYATTNAME SEARCHATTNAME))
) ;_ end not
(alert (strcat "Ein Attribut mit dem Namen: \""
SEARCHATTNAME
"\" existiert in DIESER Zeichnung nicht !"
) ;_ end strcat
) ;_ end alert
(progn
(setq SGET
(ssget
"x"
(list
(cons
2
(setq BNAMES
(vl-string-right-trim
","
(apply
'strcat
(mapcar '(lambda (X) (strcat X ",")) BLOCKLST)
) ;_ end apply
) ;_ end vl-string-right-trim
) ;_ end setq
) ;_ end cons
(cons 410 (getvar "ctab"))
) ;_ end list
) ;_ end ssget
) ;_ end setq
(if (not SGET)
(alert (strcat "Keine Blockeinfügungen für: \""
BNAMES
"\" gefunden !"
) ;_ end strcat
) ;_ end alert
(progn
(setq SSRETVAL (ssadd)) ;_ leeren Auswahlsatz erzeugen
(while (not (zerop (sslength SGET)))
(if (HASATTSTRING?
(ssname SGET 0)
SEARCHATTNAME
SEARCHWHAT
) ;_ end hasattstring?
(ssadd (ssname SGET 0) SSRETVAL)
) ;_ end if
(ssdel (ssname SGET 0) SGET)
) ;_ end while
(if (zerop (sslength SSRETVAL))
(alert
(strcat
"Keine Blockeinfügungen für folgende Werte vorhanden: "
"\nAttribut:\t"
SEARCHATTNAME
"\nAtt.wert:\t"
SEARCHWHAT
) ;_ end strcat
) ;_ end alert
(progn
(sssetfirst SSRETVAL SSRETVAL)
(princ
"\nAuswahlsatz erzeugt und markiert. AutoCAD Kommando eingeben..."
) ;_ end princ
) ;_ end progn
) ;_ end if
) ;_ end progn
) ;_ end if
) ;_ end progn
) ;_ end if
) ;_ end progn
) ;_ end if
(princ)
) ;_ end defun
(defun attributes? (ENAME / EDATA RETVAL)
(setq RETVAL '() ;_ Liste initialiseren
EDATA (entget ENAME)
) ;_ end setq
(if (assoc 66 EDATA) ;_ GC 66 fehlt, wenn Block keine Attrib's hat
(progn
(while (/= (cdr (assoc 0 EDATA)) "SEQEND") ;_ Solange die Sequenz nicht endet...
(setq EDATA (entget (entnext (cdr (assoc -1 EDATA)))))
(if (= (cdr (assoc 0 EDATA)) "ATTRIB")
(setq RETVAL
(cons
(cons (cdr (assoc 2 EDATA)) (cdr (assoc 1 EDATA)))
RETVAL
) ;_ end cons
) ;_ end setq
) ;_ end if
) ;_ end while
(setq RETVAL (reverse RETVAL))
) ;_ end progn
) ;_ end if
RETVAL
)
(defun HASATTSTRING? (ENAME ATTNAME ATTWRT / EDATA RETVAL)
(setq EDATA (entget ENAME)) ;_ end setq
(if (assoc 66 EDATA) ;_ GC 66 fehlt, wenn Block keine Attrib's hat
(progn
(while (/= (cdr (assoc 0 EDATA)) "SEQEND") ;_ Solange die Sequenz nicht endet...
(setq EDATA (entget (entnext (cdr (assoc -1 EDATA)))))
(if (= (cdr (assoc 0 EDATA)) "ATTRIB")
(if (and (= (cdr (assoc 2 EDATA)) ATTNAME)
(wcmatch (cdr (assoc 1 EDATA)) ATTWRT)
) ;_ end and
(setq RETVAL (list (cons 0 "SEQEND")))
) ;_ end if
) ;_ end if
) ;_ end while
) ;_ end progn
) ;_ end if
RETVAL
) ;_ end defun
(defun LISTBLOCKS-BYATTNAME (ATTNAME / TBLIST TBWRT)
(if (setq TBWRT (tblnext "Block" t)) ;_ ersten Eintrag der Blocktabelle finden
(progn
(setq TBLIST (list TBWRT))
(while (setq TBWRT (tblnext "Block"))
(setq TBLIST (cons TBWRT TBLIST))
) ;_ end while
(if
(setq
TBLIST (vl-remove-if
'(lambda (X) (zerop (logand 2 (cdr (assoc 70 X)))))
TBLIST
) ;_ end vl-remove-if
) ;_ end setq
(vl-remove-if-not ;_ nil's entfernen !
'(lambda (X) X)
(mapcar '(lambda (X) (HASATTNAME? ATTNAME X)) TBLIST)
) ;_ end vl-remove-if-not
) ;_ end if
) ;_ end progn
) ;_ end if
) ;_ end defun
(defun HASATTNAME? (ATTNAME CHKLIST / OBJDATA OBJLIST)
(setq OBJDATA (entget (cdr (assoc -2 CHKLIST)))
OBJLIST (list OBJDATA)
) ;_ end setq
(while (setq OBJDATA (entnext (cdr (assoc -1 OBJDATA))))
(setq OBJLIST (cons (setq OBJDATA (entget OBJDATA)) OBJLIST))
) ;_ end while
(if (vl-remove-if-not
'(lambda (X)
(and (= (cdr (assoc 0 X)) "ATTDEF")
(= (cdr (assoc 2 X)) ATTNAME)
) ;_ end and
) ;_ end lambda
OBJLIST
) ;_ end vl-remove-if-not
(cdr (assoc 2 CHKLIST))
) ;_ end if
) ;_ end defun
;_ (c:att-search) ;_ Autostart nach laden des Lisp !
(princ "\nAuswahlsatz von Blöcken nach Kriterium: Attributname/-wert erzeugen. ATT-SEARCH und AATT-SEARCH")
(princ)