Code:
;; Funktion zum Blocktauschen
;; wobei eventuell vorhandene Attributwerte
;; soweit möglich übernommen werden
;; Argumente:
;; NEWBNAME = String, Name des NEUEN Blocks
;; SELECTFUNCTION = Funktion zum Selektieren der auszutauschenden Blöcke
;; (hier sollte auch die Filtermöglichkeit gegeben werden)
;; z.B. (list 'MS:SSGET "Bitte wählen" '((0 . "Insert") (2 . "l_lampe")))
;;
;; Beispiel:
;; (MS:BLREPLACE "l_lampe2" (list 'MS:SSGET "Bitte wählen" '((0 . "Insert") (2 . "l_verteiler"))))
;; oder gekapselt:
;; (MS:SAFE-EVAL (list 'MS:BLREPLACE "l_lampe2" (list 'MS:SSGET "Bitte wählen" '((0 . "Insert") (2 . "l_verteiler")))))
(defun MS:BLREPLACE
(NEWBNAME SELECTFUNCTION / SGET)
(if (setq SGET (MS:SAFE-EVAL SELECTFUNCTION))
(if (MS:SAFE-EVAL (list 'MS:BLOCKREPLACE-BASE NEWBNAME SGET))
(princ (strcat "\nOK, >"
(itoa (sslength SGET))
"< Block/Blöcke ausgetauscht."
) ;_ end of strcat
) ;_ end of princ
) ;_ end of if
) ;_ end of if
) ;_ end of defun(defun MS:BLOCKREPLACE-BASE
(NEWBNAME SELSET / BNAMENEU NEWENT OLDENT SGET)
(MS:SAVEVARS '(("cmdecho" . 0)("cmddia" . 0)("attdia" . 0)("attreq" . 0)("filedia" . 0)) 'varsave)
(if (not (setq BNAMENEU (BLOCKNAME-REAL-CASE NEWBNAME))) ;_ Ziel-Block überhaupt vorhanden?
(setq BNAMENEU (MS:BLOCK-IMPORT NEWBNAME)) ;_ Wenn nicht existent, importiere ihn
) ;_ end of if
(if BNAMENEU
(if (setq SGET (DT:SELSET->VLA-OBJECTLIST SELSET))
(progn
(setq SGET (mapcar (function (lambda (X)
(cons X
(VLAX*GET-PROPERTIES
X
'(HYPERLINKS
INSERTIONPOINT
LAYER
LINETYPE
LINETYPESCALE
LINEWEIGHT
NORMAL
PLOTSTYLENAME
ROTATION
TRUECOLOR
VISIBLE
XSCALEFACTOR
YSCALEFACTOR
ZSCALEFACTOR
) ;_ end of Hyperlinks
) ;_ end of VLAX*GET-PROPERTIES
) ;_ end of cons
) ;_ end of lambda
) ;_ end of function
SGET
) ;_ end of mapcar
) ;_ end of setq
(foreach ELEM SGET
(command "_.-insert" BNAMENEU "0,0,0" "" "" "") ;_neues Objekt einfügen
(setq NEWENT (entlast) ;_ Objectname speichern
OLDENT (car ELEM) ;_ Alten Objectname speichern
) ;_ end of setq
(ATT-CLONE-WITHOUT OLDENT NEWENT NIL) ;_ Attribute Klonen
(VLAX*PUT-PROPERTIES NEWENT (cdr ELEM)) ;_ Eigenschafen des alten Elements übertragen
(DT:VLAX-DELETE OLDENT) ;_ altes element löschen
) ;_ end of foreach
) ;_ end of progn
) ;_ end of if
) ;_ end of if
(MS:RESTOREVARS 'varsave)
SGET
) ;_ end of defun
(defun MS:BLOCK-IMPORT (BNAME / BNAMENEW)
(MS:SAVEVARS '(("cmdecho" . 0)("cmddia" . 0)("attdia" . 0)("attreq" . 0)("filedia" . 0)) 'varsave)
(if (not (setq BNAMENEW (BLOCKNAME-REAL-CASE BNAME)))
(if (not
(setq BNAMENEW (car (FIND-FILES (list (strcat BNAME ".dwg")))))
) ;_ end of not
(princ (strcat "\nKein Block >"
BNAME
"< im AutoCAD-Suchpfad gefunden!"
) ;_ end of strcat
) ;_ end of princ
(progn
(command "_.-insert" BNAMENEW "0,0,0" "" "" "")
(entdel (entlast))
(setq
BNAMENEW (BLOCKNAME-REAL-CASE (vl-filename-base BNAMENEW))
) ;_ end of setq
) ;_ end of progn
) ;_ end of if
) ;_ end of if
(MS:RESTOREVARS 'varsave)
BNAMENEW
)
(defun BLOCKNAME-REAL-CASE (BNAME / RETVAL)
(if (not (setq RETVAL (tblsearch "block" BNAME)))
(princ
(strcat "\nKein Block >"
BNAME
"< in aktueller Zeichnung definiert!"
) ;_ end of strcat
) ;_ end of princ
(setq RETVAL (cdr (assoc 2 RETVAL)))
) ;_ end of if
retval
) ;_ end of defun
;; Argumente:
;; FROMOBJ = Ename oder vla-objekt
;; TOOBJ = Ename oder vla-objekt
;; WITHOUTLIST = Liste mit Key-Werten, die nicht übertragen werden sollen z.B.: '("ID" "NR")
(defun ATT-CLONE-WITHOUT (FROMOBJ TOOBJ WITHOUTLIST / LST)
(if (not (HASATTRIBUTES? FROMOBJ))
(princ "\nQuell-Objekt besitzt keine Attribute.")
(if (setq LST (ALL-BL-TXT FROMOBJ))
(if (not
(setq
LST (vl-remove-if
(function (lambda (X) (member (car X) WITHOUTLIST)))
LST
) ;_ end of vl-remove-if
) ;_ end of setq
) ;_ end of not
(princ "\nKeine GÜLTIGEN Attribute zum Übertragen gefunden."
) ;_ end of princ
(if (not (HASATTRIBUTES? TOOBJ))
(princ "\nZiel-Objekt besitzt keine Attribute.")
(if (not (ED-ATT2 LST TOOBJ))
(princ "\nNichts verändert.")
(princ "\nOK, Attributwerte übertragen.")
) ;_ end of if
) ;_ end of if
) ;_ end of if
) ;_ end of if
) ;_ 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
)
;; Funktion tauscht evtl. vorhandenen Attributwerte für Attributnamen aus
;; Argumente cons-Attliste z.B.: (("NR" . "10")("BAUART" . "Peitschenleuchte")) und Elementname
(defun ED-ATT2 (ATTLST ENAME / ATTOBJ ATTS MODIFIED OLD RETVAL VAL)
(setq ENAME (->VLA-OBJECT ENAME))
(if (setq VAL (ALL-BL-TXT ENAME))
(progn
(foreach NEW ATTLST
(if (setq OLD (assoc (car NEW) VAL))
(if (not (equal NEW OLD))
(setq VAL (subst NEW OLD VAL)
MODIFIED (cons NEW MODIFIED)
) ;_ end of setq
) ;_ end of if
) ;_ end of if
) ;_ end of foreach
(if MODIFIED
(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
(if (setq VAL (assoc (VLAX*GET-PROPERTY
(setq ATTOBJ (car ATTS))
'TAGSTRING
) ;_ end of VLAX*GET-PROPERTY
MODIFIED
) ;_ end of assoc
) ;_ end of setq
(VLAX*PUT-PROPERTY ATTOBJ 'TEXTSTRING (cdr VAL))
) ;_ end of if
(setq ATTS (cdr ATTS))
) ;_ end of while
(setq RETVAL ENAME)
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
RETVAL
) ;_ end of defun
(defun HASATTRIBUTES? (ENAME /)
(if (setq ENAME (->VLA-OBJECT ENAME))
(if (ISINSERT? ENAME)
(= (vlax-get-property ENAME 'HASATTRIBUTES) :vlax-true)
) ;_ end of if
) ;_ end of if
) ;_ end of defun
(defun ISINSERT? (ENAME /)
(if (setq ENAME (->VLA-OBJECT ENAME))
(= (vlax-get-property ENAME 'OBJECTNAME)
"AcDbBlockReference"
) ;_ end of =
) ;_ end of if
) ;_ 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
;;; Mapcar-Magie!
;;; Eigenschaftswerte für Objekte setzen
;;; Beispiel:
;;; Layerfarbe des aktuellen Layers auf 'Rot' setzen:
;;; (vlax*put-property nil '(Color ActiveLayer ActiveDocument) 1)
;;;
;;; Polylinie schliessen:
;;; (VLAX*PUT-PROPERTY (vlax-ename->vla-object (car (entsel))) 'CLOSED :vlax-true)
(defun VLAX*PUT-PROPERTY (OBJ PROPS VALUE /)
(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-put-property
(VLAX*GET-PROPERTY OBJ (cdr PROPS))
(car PROPS)
VALUE
) ;_ end of vlax-put-property
(vlax-put-property
OBJ
(if (listp PROPS)
(car PROPS)
PROPS
) ;_ end of if
VALUE
) ;_ end of vlax-put-property
) ;_ end of if
) ;_ end of defun
;; Funktion zum Auslesen mehrere Eigenschaften
;; Argumente:
;; ename = ename oder vla-object
;; PROPERTYLIST = Liste mit Eigenscahftsnamen
;; z.B. '(INSERTIONPOINT LAYER LINETYPE LINETYPESCALE LINEWEIGHT)
(defun VLAX*GET-PROPERTIES (ENAME PROPERTYLIST / PROP RETVAL)
(foreach PROPERTY PROPERTYLIST
(if (not (vl-catch-all-error-p
(setq PROP (vl-catch-all-apply
'VLAX*GET-PROPERTY
(list ENAME (list PROPERTY))
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
(setq RETVAL (cons (cons PROPERTY PROP) RETVAL))
) ;_ end of if
) ;_ end of foreach
RETVAL
) ;_ end of defun
;; Funktion zum Setzen mehrerer Eigenschaften
;; Argumente:
;; ename = ename oder vla-object
;; PROPERTYLIST = Liste mit Eigenscahftsnamen, z.B.:
;; '((INSERTIONPOINT . #<variant 8197 ...> )
;; (LAYER . "$BILD$25000-SW")
;; (LINETYPE . "ByLayer")
;; (LINETYPESCALE . 1.0)
;; (LINEWEIGHT . -1))
(defun VLAX*PUT-PROPERTIES (ENAME PROPERTYLIST / PROP RETVAL)
(foreach PROPERTY PROPERTYLIST
(if (not (vl-catch-all-error-p
(vl-catch-all-apply
'VLAX*PUT-PROPERTY
(list ENAME (car PROPERTY) (cdr PROPERTY))
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
) ;_ end of not
(setq RETVAL (cons PROPERTY RETVAL))
) ;_ end of if
) ;_ end of foreach
RETVAL
) ;_ end of defun
(defun DT:VLAX-DELETE (ENAME /)
(if (setq ENAME (->VLA-OBJECT ENAME))
(if (vlax-method-applicable-p ENAME 'DELETE)
(progn
(vlax-invoke-method ENAME 'DELETE)
(if (not (vlax-object-released-p ENAME))
(vlax-release-object ENAME)
) ;_ end of if
'T
) ;_ end of progn
) ;_ end of if
) ;_ end of if
) ;_ end of defun
;; Funktion wendet findfile auf die übergebene Liste an
(defun FIND-FILES (LST / RETVAL)
(if (member NIL (setq RETVAL (mapcar 'findfile LST)))
(setq RETVAL NIL)
) ;_ end of if
RETVAL
) ;_ end of defun
(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: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
) ;_ 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
;;; 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 zum sicheren Ausführen von Code
;; Beispiel:
;; Normaler Aufruf:
;; (setq value (MS_multiList "Titel" "Aufforderung" '("C" "F") '("A" "B" "C" "D" "E" "F" "G")))
;; Safe Aufruf:
;; (setq retval (MS:SAFE-EVAL '(MS_multiList "Titel" "Aufforderung" ("C" "F") ("A" "B" "C" "D" "E" "F" "G"))))
;; oder
;; (setq retval (MS:SAFE-EVAL (list 'MS_multiList "Titel" "Aufforderung" '("C" "F") '("A" "B" "C" "D" "E" "F" "G"))))
(defun MS:SAFE-EVAL (EVALFUNCTION / ARGLST FUNCNAME RETVAL)
(if EVALFUNCTION
(if (setq FUNCNAME (car EVALFUNCTION))
;|(and (setq FUNCNAME (car EVALFUNCTION))
(setq ARGLST (cdr EVALFUNCTION))
) ;_ end of and
|;
(progn
(setq ARGLST (cdr EVALFUNCTION))
(if (vl-catch-all-error-p
(setq RETVAL (vl-catch-all-apply FUNCNAME ARGLST))
) ;_ end of vl-catch-all-error-p
(setq RETVAL NIL)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of if
RETVAL
) ;_ end of defun
(defun MS:SAVEVARS (LISTOFPAIRS SYMBOLNAME / VARLIST)
(foreach PAIR LISTOFPAIRS
(setq varlist
(cons
(cons (car PAIR) (getvar (car PAIR)))
varlist
) ;_ end of cons
) ;_ end of setq
(setvar (car PAIR) (cdr PAIR))
) ;_ end of foreach
(PUSH! varlist SYMBOLNAME)
) ;_ end of defun
(defun MS:RESTOREVARS (SYMBOLNAME)
(if (setq VARLIST (POP! SYMBOLNAME))
(foreach PAIR VARLIST
(setvar (car PAIR) (cdr PAIR))
) ;_ end of foreach
) ;_ end of if
VARLIST
) ;_ end of defun
;;; Legt ein Element auf einem Stapel ab und gibt es zurück
;;; Notwendig z.B. für das Wiederherstellen von Uservariablen u.ä.
;;; Argumente:
;;; ELM = Name der Variablen
;;; STACKSYM = Name des Stacks
(defun PUSH! (ELM STACKSYM /)
(set STACKSYM (cons ELM (eval STACKSYM)))
ELM
) ;_ end of defun
;;; Nimmt ein Element von einem Stapel herunter und gibt es zurück
;;; Notwendig z.B. für das Wiederherstellen von Uservariablen u.ä.
;;; Argumente:
;;; STACKSYM = Name des Stacks
(defun POP! (STACKSYM / ELM)
(setq ELM (car (eval STACKSYM)))
(set STACKSYM (cdr (eval STACKSYM)))
ELM
) ;_ end of defun
(defun MS:SSGET (QUESTION FILTERLIST / SGET)
(if (not (setq SGET (IMPLIZIT?+FILTER FILTERLIST)))
(progn
(setq QUESTION (strcat "\n" QUESTION)) ;_ end of setq
(princ QUESTION)
(setq SGET (MS:SAFE-EVAL (list 'ssget FILTERLIST)))
) ;_ end of progn
(sssetfirst nil nil)
) ;_ end of if
SGET
)
(defun IMPLIZIT?+FILTER (FILTERLIST)
(ssget "_I" FILTERLIST)
) ;_ end of defun
Foren auf CAD.de (alle Foren)
| 
nur durch programmiertechnische Kniffe erzeugen, nicht mit Acad-Befehlen.
- 
