Code:
(defun C:GETINSERTSBY-VALUE (/ QUESTION SEARCHSTRING WHAT?)
(sssetfirst)
(if (not $$GLOBAL-LAST-SEARCHSTRING)
(setq QUESTION
"\nBitte Such-Text eingeben (wcmatch-Wildcards zulässig): "
)
(setq QUESTION
(strcat
"\nBitte Such-Text eingeben (wcmatch-Wildcards zulässig) <"
$$GLOBAL-LAST-SEARCHSTRING
">: "
)
)
)
(setq SEARCHSTRING (getstring 't QUESTION))
(cond
((and (equal SEARCHSTRING "") $$GLOBAL-LAST-SEARCHSTRING)
(setq SEARCHSTRING $$GLOBAL-LAST-SEARCHSTRING)
)
((not (equal SEARCHSTRING ""))
(setq $$GLOBAL-LAST-SEARCHSTRING SEARCHSTRING)
)
('t (setq $$GLOBAL-LAST-SEARCHSTRING NIL))
)
(if (not $$GLOBAL-LAST-SEARCHSTRING)
(princ "\nKein Such-Text eingegeben, Funktionsende.")
(progn
(initget "Attributname attributWert")
(if (not (setq WHAT?
(getkword
"\nIn welchem Bereich soll der String gesucht werden? [Attributname/attributWert] <attributWert>: "
)
)
)
(setq WHAT? "attributWert")
)
(if (equal WHAT? "Attributname")
(setq WHAT? (DT:OBJECTLIST->SELSET
(FINDBLOCKSWITHATTDEFLIKE
(list $$GLOBAL-LAST-SEARCHSTRING)
)
)
)
(setq WHAT? (DT:OBJECTLIST->SELSET
(FINDBLOCKSWITHATTVALLIKE
(list $$GLOBAL-LAST-SEARCHSTRING)
)
)
)
)
(if WHAT?
(progn
(sssetfirst WHAT? WHAT?)
(princ "\nOK, gefundene Inserts markiert...")
)
(princ "\nKEINE Inserts für Such-Text gefunden...")
)
)
)
(princ)
)
;;; Findet Blöcke im aktuellen Bereich, deren Attributdefinitionen einen bestimmten Namen haben
(defun FINDBLOCKSWITHATTDEFLIKE (LISTOFATTNAMES /)
(FINDBLOCKSWITH-BASE LISTOFATTNAMES 'car)
)
(defun FINDBLOCKSWITHATTVALLIKE (LISTOFVALUES /)
(FINDBLOCKSWITH-BASE LISTOFVALUES 'cdr)
)
;; Findet Strings in Inserts (wcmatch-like)
;; Verwendet die Liste die Funktion "ALL-BL-TXT"
;; zurückgibt -> '(("ATTNAME" . "ATTVALUE")(...))
;; SYMBOL gibt an, was denn nun relevant ist,
;; das 'car oder das 'cdr des punktierten Paares
(defun FINDBLOCKSWITH-BASE (LISTOFSTRINGS SYMBOL /)
(setq VGLSTR (MS_STRDELIMITED LISTOFSTRINGS ","))
(if (setq
SGET (ssget "x"
(list (cons 0 "Insert") (cons 410 (getvar "ctab")))
) ;_ end of ssget
) ;_ end of setq
(if (setq SGET (DT:SELSET->VLA-OBJECTLIST SGET))
(if (setq SGET
(vl-remove-if-not
(function
(lambda (X)
(= (VLAX*GET-PROPERTY X 'HASATTRIBUTES) :vlax-true)
) ;_ end of lambda
) ;_ end of function
SGET
) ;_ end of VL-REMOVE-IF-not
) ;_ end of setq
(progn
(setq SGET
(mapcar
(function
(lambda (X) (list X (mapcar SYMBOL (ALL-BL-TXT X))))
) ;_ end of function
SGET
) ;_ end of mapcar
) ;_ end of setq
(if (setq SGET
(vl-remove-if-not
(function
(lambda (X)
(vl-member-if
(function (lambda (Y) (wcmatch Y VGLSTR)))
(cadr X)
) ;_ end of vl-member-if
) ;_ end of lambda
) ;_ end of function
SGET
) ;_ end of vl-remove-if-not
) ;_ end of setq
(setq SGET (mapcar 'car SGET))
(setq SGET NIL)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of if
) ;_ end of if
SGET
)
(defun MS_STRDELIMITED (LST TOKEN /)
(vl-string-right-trim
TOKEN
(apply 'strcat
(mapcar '(lambda (X) (strcat X TOKEN)) LST)
) ;_ end of apply
) ;_ end of vl-string-right-trim
)
(defun DT:SELSET->VLA-OBJECTLIST (SELSET / RETVAL)
(if (eq (type SELSET) 'PICKSET)
(if (setq RETVAL (DT:SELSET->ENAMELIST SELSET))
(setq RETVAL
(mapcar (function (lambda (X) (->VLA-OBJECT X))) RETVAL)
) ;_ end of setq
) ;_ end of if
) ;_ end of if
RETVAL
)
;;; z.B. (DT:SELSET-LIKE-DEFINITION (list (cons 0 "IMAGE")(cons 8 "*$BILD$@*")))
(defun DT:SELSET->ENAMELIST (SELSET / INDEX RETVAL)
(if (eq (type SELSET) 'PICKSET)
(progn
(setq INDEX 0)
(repeat (sslength SELSET)
(setq RETVAL (cons (ssname SELSET INDEX) RETVAL)
INDEX (1+ INDEX)
) ;_ end of setq
) ;_ end of repeat
) ;_ end of progn
) ;_ end of if
retval
) ;_ end of defun
(defun DT:OBJECTLIST->SELSET (OBJECTLIST / SGET)
(gc)
(if (setq OBJECTLIST
(vl-remove-if
'null
(mapcar (function (lambda (X) (->ENAME X)))
OBJECTLIST
)
)
)
(progn
(setq SGET (ssadd))
(foreach ELEM OBJECTLIST
(setq SGET (ssadd ELEM SGET))
)
)
)
(if SGET
(if (> (sslength SGET) 0)
SGET
)
)
)
;;; Funktion gibt vla-Objekt zurück, wenn Lisp-Objekt oder vla-Objekt
;;; übergeben worden sind. Ansonsten nil
(defun ->VLA-OBJECT (ENAME /)
(cond
((= (type ENAME) 'ENAME) (vlax-ename->vla-object ENAME))
((= (type ENAME) 'VLA-OBJECT) ENAME)
(t NIL)
) ;_ end of cond
) ;_ end of defun
;;; Funktion gibt Ename zurück, wenn Lisp-Objekt oder vla-Objekt
;;; übergeben worden sind. Ansonsten nil
(defun ->ENAME (ENAME /)
(cond
((= (type ENAME) 'VLA-OBJECT) (vlax-vla-object->ename ENAME))
((= (type ENAME) 'ENAME) ENAME)
(t NIL)
) ;_ end of cond
) ;_ end of defun
;;; Mapcar-Magie!
;;; Eigenschaftswerte aus Objekten lesen
;;; Beispiel:
;;; Layerfarbe des aktuellen Layers abfragen:
;;; (vlax*get-property nil '(Color ActiveLayer ActiveDocument))
;;;
;;; Abfragen, ob eine Polylinie geschlossen ist:
;;; (VLAX*GET-PROPERTY (vlax-ename->vla-object (car (entsel))) 'CLOSED)
(defun VLAX*GET-PROPERTY (OBJ PROPS /)
(if (->VLA-OBJECT OBJ) ;_ Wenn vla-Objekt draus gemacht werden kann...
(setq OBJ (->VLA-OBJECT OBJ)) ;_ mache auf jeden Fall eines draus
) ;_ end of if
(if (null OBJ)
(setq OBJ (vlax-get-acad-object))
) ;_ end of if
(if (and (listp PROPS) (cdr PROPS))
(vlax-get-property
(VLAX*GET-PROPERTY OBJ (cdr PROPS))
(car PROPS)
) ;_ end of vlax-get-property
(vlax-get-property
OBJ
(if (listp PROPS)
(car PROPS)
PROPS
) ;_ end of if
) ;_ end of vlax-get-property
) ;_ end of if
) ;_ end of defun
;;; Funktion durchsucht den Block, der über ename übergeben wird,
;;; nach ATTRIB's und erzeugt 'ne Textliste
;;; Retval: Liste der Texte oder nil
;; Hier vl-Version
(defun ALL-BL-TXT (ENAME / EDATA RETVAL ATTS)
(setq ENAME (->VLA-OBJECT ENAME)
RETVAL '() ;_ Liste initialiseren
) ;_ end setq
(if (= (VLAX*GET-PROPERTY ENAME 'HASATTRIBUTES) :vlax-true)
(progn
(setq ATTS (vlax-safearray->list
(vlax-variant-value
(vlax-invoke-method ENAME 'GETATTRIBUTES)
) ;_ end of vlax-variant-value
) ;_ end of vlax-safearray->list
) ;_ end of setq
(while ATTS
(setq RETVAL
(cons (cons
(VLAX*GET-PROPERTY (car ATTS) 'TAGSTRING)
(VLAX*GET-PROPERTY (car ATTS) 'TEXTSTRING)
) ;_ end of cons
RETVAL
) ;_ end of cons
) ;_ end of setq
(setq ATTS (cdr ATTS))
) ;_ end of while
(setq RETVAL (reverse RETVAL))
) ;_ end progn
) ;_ end if
RETVAL
)
Foren auf CAD.de (alle Foren)
| 
- Thomas -
