Code:
;; --------------------------------------------------------------------------------------------------- ;;
;; -- BLOCK_NEW_BASISPUNKT : Wählt Block durch Anpicken einer Blockreferenz aus setzt einen neuen -- ;;
;; -- Basispunkt und updatet auf Wunsch alle Referenzen des Blockes -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- Aufschreiber : Th.Krüger , Eberswalde -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- Datum : 10.03.04 -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- Freeware oder besser BTN-WARE ("Better than Nothing" ..damit das AutoCad besser werde ) -- ;;
;; -- Dabei Danke an alle , die nach dem gleichen Grundsatz Anregungen, Tipps und Lisp's zur -- ;;
;; -- Verfügung stellen... und auf deren Grundlagen so manches meinerseits fußt... -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- Besonderer Dank an MAPCAR (http://www.autolisp.mapcar.net) für seinen Error-Handler -- ;;
;; --------------------------------------------------------------------------------------------------- ;;;; --------------------------------------------------------------------------------------------------- ;;
;; -- StartErrorHandler : Stapelbare Fehlerbehandlungsroutine -- ;;
;; -- NAME ist ein frei wählbarer String. Wenn eine (*error*)-Funktion etwas -- ;;
;; -- auf dem Bildschirm ausgibt, setzt sie diesen Namen dazu, damit man -- ;;
;; -- unterscheiden kann, was von welcher Instanz des Errhandlers kommt. -- ;;
;; -- UNDOMODE kann T oder nil sein und gibt an, ob im Fehler- bzw. Abbruchs- -- ;;
;; -- fall gleich der Befehl 'Z' ausgeführt werden soll, um alle bis dahin -- ;;
;; -- vorgenommen Aktionen sofort rückgängig zu machen. -- ;;
;; -- VARS_TO_SAVE sind die zu setzenden Systemvariablen und Globalen Variablen -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- .. Aufruf: (defun c:Test( / ) -- ;;
;; -- (startErrorHandler "Funktion TEST" 'T -- ;;
;; -- '(("cmdecho" 0)("filedia" 0)("MYOWN" nil)) -- ;;
;; -- ) -- ;;
;; -- ....... -- ;;
;; -- (endErrorHandler) -- ;;
;; -- ) -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun StartErrorHandler( NAME UNDOMODE VARS_TO_SAVE /
ErrorTemplate SAVELIST)
;; -- Schablone für programmspezifische Fehlerroutine -- ;;
(setq ErrorTemplate
'( (MSG / NAME UNDO SAVEDVARS PREVIOUSHANDLER ZAEHLER AUSWAHLSATZ)
;... Zeile wird eventuell noch eingesetzt.. Siehe unten ....
(while(>(getvar "cmdactive")0)(command)) ; noch ein "ACAD-Befehl aktiv ??, dann Abbrechen!
(command"_undo""_end") ; Undo-Endmarkierung
(if (and undo msg) (command"_u")) ; wenn Undo True, dann alle Aktionen zurücksetzen
(foreach PAIR SAVEDVARS ; Veränderte Variablen zurücksetzen
(if (Getvar (car PAIR)) ; ist es eine Systemvariable ?
(setvar(car PAIR)(cadr PAIR)) ; dann zurücksetzen mit SETVAR
(set (read(car PAIR)) (cadr PAIR)) ;..sonst mit SET zurücksetzen
)
)
(setq ZAEHLER 0)
(setq AUSWAHLSATZ (ssget "X"))
(while (and AUSWAHLSATZ (setq ELEMENT (ssname AUSWAHLSATZ ZAEHLER)))
(redraw ELEMENT 4) ; Ausleuchten abschalten
(setq ZAEHLER (1+ ZAEHLER))
)
(setq *error* previousHandler) ; Fehlerroutine auf ursprüngliche Fehlerroutine setzen
(if msg
(progn
(princ(strcat"\n" Name ": \"" msg "\"")) ; und Fehlermeldung ausgeben
(if previousHandler(previousHandler msg))
)
)
)
)
;; -- Systemvariablen behandeln -- ;
(if (=(type VARS_TO_SAVE) 'LIST)
(foreach PAIR VARS_TO_SAVE ; Liste mit den Systemvariablen und den zu setzenden Werten durchlaufen
(if (=(type PAIR) 'LIST)
(if (=(length PAIR) 2)
(if (=(type(car PAIR)) 'STR)
(if (Getvar (car PAIR)) ; konnte Systemvariable ausgelesen werden ?
(progn
(setq SAVELIST (append SAVELIST; Namen der Systemvariable und alten Wert als "2er-Liste"
(list (list (car PAIR) (getvar (car PAIR))))) ; .. in SAVELIST
) ; speichern ..
(setvar(car PAIR)(cadr PAIR)) ; anschließend Systemvariable auf neuen Wert setzen
)
(progn
(setq SAVELIST (append SAVELIST ; Namen der Variable und alten Wert als "2er-Liste"
(list (list (car PAIR) (eval(read(car PAIR)))))) ; .. in SAVELIST
) ; speichern ..
(set (read(car PAIR)) (cadr PAIR)) ; anschließend Variable auf neuen Wert setzen
)
)
)
)
)
)
)
(command"_undo""_begin") ; Undo-Markierung für "Rückgängig ab diesem Punkt" setzen
;; -- Error-Handler installieren -- ;;
(setq *error*
(append ; und ErrorTemplate initialisieren
(list(car ErrorTemplate)) ; erste Zeile (Unterliste von ErrorTemplate) hinzufügen
(if undomode'((setq undo 'T))) ; .. ergänzende Zeilen einfügen ..
(list
(list 'setq
'PreviousHandler
(cons'quote(list *error*))
)
)
(list(list 'setq 'name name))
(list
(cons'setq
(cons'savedvars
(list(cons'quote(list savelist)))
)
)
)
(cdr ErrorTemplate) ; Rest von ErroTemplate hinzufügen ....
) ; end [APPEND]
) ; end [SETQ *ERROR*]
) ; end [DEFUN]
;; --------------------------------------------------------------------------------------------------- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- EndErrorHandler : Beendet Nutzerspezifischer Error-Handling -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun EndErrorHandler( / )
(*error* nil) ; alle Änderungen von StartErrorHandler restaurieren
)
;; --------------------------------------------------------------------------------------------------- ;;
;; -- *********** und hier gehts los : *********************************************************** -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- IS_NUM_LISTE : Überprüft, ob in LISTE übergebenen Wert eine Liste ist, welche ANZAHL -- ;;
;; -- numerische Einträge hat -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun IS_NUM_LISTE (LISTE ANZAHL)
(and(=(type LISTE) 'LIST)(=(length LISTE) ANZAHL)(not(vl-member-if-not '(lambda(X)(numberp X))LISTE)))
)
;; --------------------------------------------------------------------------------------------------- ;;
(vl-load-com) ; ACtiveX-Schnittstelle initialisieren
;; --------------------------------------------------------------------------------------------------- ;;
;; -- BLOCK_SET_ORIGIN : Setzt neuen Basispunkt im Block (mit vlax-put-Origin) -- ;;
;; -- Bei fehlerhaften Parametern oder nicht existierendem Block wir" nil" -- ;;
;; -- zurückgegeben, bei erfolgreichem Versetzen 'T(rue) -- ;;
;; -- BLOCKNAME [STRING] - Name eines existierenden Blockes -- ;;
;; -- VEKTOR [LIST of 3x REAL] - Verschiebungsvektor (x,y,z) des Basispunktes -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun BLOCK_SET_ORIGIN ( BLOCKNAME VEKTOR / BLOCK ORIGIN)
(if (and (=(type BLOCKNAME) 'STR)(tblsearch "BLOCK" BLOCKNAME)
(IS_NUM_LISTE VEKTOR 3)
)
(progn
(setq BLOCK (vla-item ; Blockdefinition als VLA-Objket holen
(vla-get-blocks
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
BLOCKNAME
)
)
(setq Origin (vlax-safearray->list ; Block-Definitions-Punkt holen
(vlax-variant-value
(vlax-get-property
BLOCK
'Origin
)
)
)
)
; Vektor auf evtl. Block-Definitions-Punkt <> (0.0 0.0 0.0) umrechnen
(setq VEKTOR (mapcar '- (mapcar '(lambda ( X )(* X -1.0)) VEKTOR)ORIGIN))
(vlax-put-property ; Block-Definitions-Punkt auf (0.0 0.0 0.0) setzen
BLOCK
'Origin
(vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 2))
'(0.0 0.0 0.0)
)
)
; alle Blockelemente versetzen
(vlax-for BLOCKELEMENT BLOCK
(vlax-invoke-method BLOCKELEMENT 'MOVE
(vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 2))
'(0.0 0.0 0.0)
)
(vlax-safearray-fill (vlax-make-safearray vlax-vbdouble (cons 0 (-(length VEKTOR)1)))
VEKTOR
)
)
)
)
)
)
;; --------------------------------------------------------------------------------------------------- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- VEKTOR_ROTATE : Berechnet einen um Winkel ALPHA gedrehten 2D-Vektor (mit Lisp) -- ;;
;; -- PARAMETER : VEKTOR_XY .. [List 2x REAL] - VektorProjektion auf die xy-Ebene -- ;;
;; -- ALPHA .. [REAL] - Drehwinkel in Rad -- ;;
;; -- RÜCKGABE : VEKTOR_XY .. [List 2x REAL] - um ALPHA gedrehte VektorProjektion -- ;;
;; -- auf die xy-Ebene -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun VEKTOR_ROTATE ( VEKTOR_XY ALPHA / X Y )
(if(and(=(type VEKTOR_XY)'LIST)(numberp(setq X (car VEKTOR_XY))) ; Parameterüberprüfung
(numberp(setq Y (cadr VEKTOR_XY)))
(numberp ALPHA)
)
(progn
(setq ALPHA(+(cond ; Winkel der Vektorprojektion auf xy-Ebene bezüglich x berechnen
((and(zerop X)(>= Y 0)) (/ Pi 2.0) )
((and(zerop X)(< Y 0)) (/ Pi -2.0) )
((and(< X 0)(>= Y 0)) (+(atan (/ Y X ))PI) )
((and(< X 0)(< Y 0)) (-(atan (/ Y X ))PI) )
('T (atan (/ Y X )) )
) ;..und Drehwinkel der Tranformation..
ALPHA ; .. hinzuaddieren
)
)
(mapcar '(lambda(X) (if (<(abs X)1e-8) 0.0 X))
(list (*(cos ALPHA) (sqrt (+(* X X)(* Y Y))))(*(sin ALPHA) (sqrt (+(* X X)(* Y Y)))))
)
)
)
)
;; --------------------------------------------------------------------------------------------------- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- INSERT_UPDATE : Transformiert ein Insert bezüglich eines neuen Basispunkte der -- ;;
;; -- Blockdefinition anhand des Basispunktverschiebevektors -- ;;
;; - PARAMETER : INSERT .. [ENAME] - Objekt-ID der Blockreferenz -- ;;
;; -- VEKTOR .. [List 3x REAL] - Verschibevektor des Blockbasispunktes -- ;;
;; -- RÜCKGABE : Entget-Liste der modifizierten Blockrefernz -- ;;
;; -- in Fehlerfall "nil" -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun INSERT_UPDATE ( INSERT VEKTOR MODUS / OBJEKTDATEN SKALIERUNG ROTATION ORIGIN)
(if (and(=(type INSERT) 'ENAME) ; Parameterüberprüfung ( der Allgemeingültigkeit wegen ;-) )
(=(cdr(assoc 0 (setq OBJEKTDATEN (entget INSERT)))) "INSERT")
(IS_NUM_LISTE VEKTOR 3)
)
(progn
(setq SKALIERUNG (list (cdr(assoc 41 OBJEKTDATEN)) ; Inserteigenschaften auslesen
(cdr(assoc 42 OBJEKTDATEN))
(cdr(assoc 43 OBJEKTDATEN))))
(setq ROTATION (list (cdr(assoc 50 OBJEKTDATEN)) 0.0 ))
(setq VEKTOR (mapcar '* VEKTOR SKALIERUNG)) ; Verschiebungsvektor erstmal skalieren
(setq VEKTOR (append (VEKTOR_ROTATE(list (car VEKTOR)(cadr VEKTOR)) (car ROTATION))
(list(cadr(VEKTOR_ROTATE(list (car VEKTOR)(caddr VEKTOR)) (cadr ROTATION))))
) ; und anschließend entsprechend drehen
)
(cond
((or(= MODUS "B")(= MODUS "b")) ; Insert berücksichtigen
(setq OBJEKTDATEN (subst(cons 10 (mapcar '+ (cdr(assoc 10 OBJEKTDATEN)) VEKTOR))
(assoc 10 OBJEKTDATEN)
OBJEKTDATEN
)
)
(entmod OBJEKTDATEN) ; und Insert mit neuem Basispunkt updaten
)
((or(= MODUS "A")(= MODUS "a")) ; eventuelle Attribute berücksichtigen
(if (assoc 66 OBJEKTDATEN) ; GC 66 fehlt, wenn Block keine Attrib's hat
(while (/= (cdr (assoc 0 OBJEKTDATEN)) "SEQEND") ; solange die Sequenz nicht endet...
(setq OBJEKTDATEN (entget (entnext (cdr (assoc -1 OBJEKTDATEN)))))
(if (= (cdr (assoc 0 OBJEKTDATEN)) "ATTRIB")
(progn
(setq OBJEKTDATEN (subst(cons 10 (mapcar '- (cdr(assoc 10 OBJEKTDATEN)) VEKTOR))
(assoc 10 OBJEKTDATEN)
OBJEKTDATEN
)
)
(entmod OBJEKTDATEN) ; und ATTRIB mit neuem Basispunkt updaten
)
)
)
)
)
)
)
)
)
;; --------------------------------------------------------------------------------------------------- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- BLOCK_NEW_BASISPUNKT : Setzt einen neuen Basispunkt im Block und updatet alle Referenzen -- ;;
;; -- ( interne TOOL-Funktion ) -- ;;
;; -- PARAMETER : NAME .. [String] - Blockname -- ;;
;; -- ORIGIN .. [List 3x REAL] - Startpunkt des Basispunktverschiebevektors -- ;;
;; -- NEW_ORIGIN .. [List 3x REAL] - Endpunkt des Basispunktverschiebevektors -- ;;
;; -- ROTATION .. [List 3x REAL] - Drehwinkel des Basispunktverschiebevektors -- ;;
;; -- SKALIERUNG .. [List 3x REAL] - Skalierung des Basispunktverschiebevektors -- ;;
;; -- MOD1 .. ["J" "j" egal] - Modus Transformation Basispunktverschiebevektor -- ;;
;; -- MOD2 .. ["J" "j" egal] - Modus Blockreferenzupdate -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun BLOCK_NEW_BASISPUNKT (NAME ORIGIN NEW_ORGIN ROTATION SKALIERUNG MOD1 MOD2 /
VEKTOR AUSWAHL INDEX BLOCKDEF)
(if (and (=(type NAME)'STR)(tblsearch "BLOCK" NAME) ; Parameterüberprüfung
(IS_NUM_LISTE ORIGIN 3)(IS_NUM_LISTE NEW_ORIGIN 3)
(IS_NUM_LISTE ROTATION 2)(IS_NUM_LISTE SKALIERUNG 3)
)
(progn
(setq VEKTOR (mapcar '- NEW_ORIGIN ORIGIN)) ; Verschiebungsvektor wie eingegeben ermitteln
(if (or(= MOD1 "J")(= MOD1 "j")); soll Vektor auf gewählte Insertransformation umgerechnet werden ?
(progn
(setq SKALIERUNG (mapcar '(lambda ( X )(/ 1.0 X)) SKALIERUNG)) ; Zurückskalierfaktoren
(setq ROTATION (mapcar '(lambda ( X )(* -1.0 X)) ROTATION)) ; Zurückdrehwinkel
(setq VEKTOR (append (VEKTOR_ROTATE(list (car VEKTOR)(cadr VEKTOR)) (car ROTATION))
(list(cadr(VEKTOR_ROTATE(list (car VEKTOR)(caddr VEKTOR)) (cadr ROTATION))))
) ; zuerst Verschiebungsvektor zurückdrehen
)
(setq VEKTOR (mapcar '* VEKTOR SKALIERUNG)) ; und dann auf Originalmaßstab zurückskalieren
)
)
(BLOCK_SET_ORIGIN NAME VEKTOR) ; beim Block den neuen Basispunkt definieren
(if (or(= MOD2 "B")(= MOD2 "b") ; Blockreferenzen auch transformieren ?
(= MOD2 "A")(= MOD2 "a"))
(progn
; .................................... und jetzt alle Blockreferenzen auf Blattebene updaten ..
(setq AUSWAHL (ssget "_X" '((0 . "INSERT"))))
; (ssget "_X" (list '(0 . "INSERT") (cons 2 NAME) ))) ; funzt nicht bei unbenannten Blöcken !
(setq INDEX 0) ; Auswahlindex auf 0 setzen
(if AUSWAHL
(repeat (sslength AUSWAHL) ; Auswahl durchlaufen und abarbeiten...
(if (=(strcase(cdr(assoc 2 (entget(ssname AUSWAHL INDEX)))))(strcase NAME))
(INSERT_UPDATE(ssname AUSWAHL INDEX) VEKTOR MOD2) ; Blockreferenz modifizieren
)
(setq INDEX(1+ INDEX)) ; Auswahlindex erhöhen und nächstes Element..
) ; end [REPEAT]
)
; ................................... und jetzt alle Blockreferenzen in verschachtelten Blöcken
(while (setq BLOCKDEF (tblnext "BLOCK" (null BLOCKDEF))) ; BLocktable durchlaufen
(if (and(/=(logand(cdr(assoc 70 BLOCKDEF))4)4) ; ist Block kein kein XREF, und
(or(/= (logand(cdr(assoc 70 BLOCKDEF))1)1) ; auch kein unbenannter Block
(=(substr NAME 1 2) "*U")
)
)
(progn
(setq OBJEKT (cdr (assoc -2 BLOCKDEF))) ; Adresse der Blockelemente holen
(while OBJEKT ; und solange nicht alle Blockelemente abgearbeitet sind ...
(if (and (=(cdr(assoc 0 (entget OBJEKT))) "INSERT") ; Blockreferenz gefunden
(=(cdr(assoc 2 (entget OBJEKT))) NAME))
(INSERT_UPDATE (ssname AUSWAHL INDEX)VEKTOR MOD2) ; Blockreferenz modifizieren
)
(setq OBJEKT (entnext OBJEKT)) ; nächstes Blockelement, Blockende="nil"
) ;end [WHILE BLOCKELEMENT]
(entupd (cdr (assoc -2 BLOCKDEF))) ; Block modifizieren
)
)
) ; end [WHILE]
)
)
)
)
)
;; --------------------------------------------------------------------------------------------------- ;;
;; --------------------------------------------------------------------------------------------------- ;;
;; -- BLOCK_NEW_BASISPUNKT : Wählt Block durch Anpicken einer Blockreferenz aus setzt einen neuen -- ;;
;; -- Basispunkt und updatet auf Wunsch alle Referenzen des Blockes -- ;;
;; -- ( Befehlszeilen-Funktion ) -- ;;
;; -- PARAMETER : keine / Rückgabe : keine -- ;;
;; --------------------------------------------------------------------------------------------------- ;;
(defun C:BLOCK_NEW_BASISPUNKT ( / OBJEKT OBJEKTDATEN NAME ORIGIN ROTATION SKALIERUNG MOD1 MOD2)
(startErrorHandler "BLOCK_NEW_BASISPUNKT" 'T '(("cmdecho" 0)("expert" 0)
("HIGHLIGHT" 1)("OSMODE" 639)("ATTREQ" 0)))
(if (and(setq OBJEKT (ssget "_:S" '((0 . "INSERT")))) (setq OBJEKT (ssname OBJEKT 0)))
(progn
(setq OBJEKTDATEN (entget OBJEKT))
(setq NAME (cdr(assoc 2 OBJEKTDATEN))) ; Blockname merken
(setq ORIGIN (cdr(assoc 10 OBJEKTDATEN)))
(setq SKALIERUNG (list (cdr(assoc 41 OBJEKTDATEN)) ; Skalierung der Blockreferenz
(cdr(assoc 42 OBJEKTDATEN))
(cdr(assoc 43 OBJEKTDATEN))))
(setq ROTATION (list (cdr(assoc 50 OBJEKTDATEN)) 0.0)) ; Drehwinkel der Blockreferenz
(if (setq NEW_ORIGIN (getpoint ORIGIN "\nNeuer Basispunkt : "))
(progn
(if (or (vl-member-if-not '(lambda ( X )(equal X 1.0))SKALIERUNG) ; INSERT skaliert oder
(vl-member-if-not '(lambda ( X )(zerop X))ROTATION)) ; rotiert ? , dann ..
(progn
(princ "\nGewählte Referenz ist transformiert.")
(initget "J N")
(if (not(setq MOD1(getkword "\nBasispunkt-Verschiebesvektor umrechen? [J]a/[N]ein:<J> ")))
(setq MOD1 "J") ; Vorgabe bei "Enter"-Eingabe setzen
)
)
(setq MOD1 "N")
)
(initget "B A N")
(if (not(setq MOD2(getkword (strcat"\n[B]lockreferenzen/[A]ttribute/[N]ichts "
"auf neuen Einfügepunkt umrechnen? <B>"))))
(setq MOD2 "B") ; Vorgabe bei "Enter"-Eingabe setzen
)
; Parametervariante zum Setzen des Basispunktes aufrufen
(BLOCK_NEW_BASISPUNKT NAME ORIGIN NEW_ORIGIN ROTATION SKALIERUNG MOD1 MOD2)
(command "._regen") ; Zeichnung regenerieren
)
(princ "\nKeinen gültigen Punkt eingegeben!\n")
)
)
(princ "\nKeine Blockreferenz gewählt!\n")
)
(EndErrorHandler) ; Errorhandler wieder deinstallieren
(princ)
)
;; --------------------------------------------------------------------------------------------------- ;;
(princ "\n Aufruf mit : BLOCK_NEW_BASISPUNKT\n")
Foren auf CAD.de (alle Foren)
| 
"Lisp?!?! Why the Hell did you pick the most arcane, obscure, and hopelessly-rooted-in-the-computer-science-department language in the world for an AutoCAD programming language?" Read the whole story: 
