538 lines
15 KiB
Common Lisp
538 lines
15 KiB
Common Lisp
;;;---------------------------------------------------------------------------;
|
|
;;;
|
|
;;; XPLODE.LSP
|
|
;;; Copyright (C) 1990 by Autodesk, Inc.
|
|
;;;
|
|
;;; Jan S. Yoder & K.C. Jones Version 1.0
|
|
;;;
|
|
;;; --------------------------------------------------------------------------;
|
|
;;; šBERSICHT
|
|
;;;
|
|
;;;
|
|
;;; Dieses Programm ersetzt den URSPRUNG Befehl in AutoCAD. Hiermit k”nnen
|
|
;;; alle Attribute einzelner Objekte eines Blocks oder einer Gruppe von
|
|
;;; Bl”cken bei der Zerlegung in die Einzelteile kontrolliert werden. Es gibt
|
|
;;; einige wesentliche Unterschiede zwischen XPLODE und dem URSPRUNG-Befehl
|
|
;;; in AutoCAD.
|
|
;;;
|
|
;;; Zum ersten k”nnen unbegrenzt viele Objekte selektiert werden. Alle
|
|
;;; Bemaáungen, PolyLinien und PolyNetze sowie Blockeinf�gepunkte werden
|
|
;;; aus der ausgew„hlten Gruppe selektiert und k”nnen mit dem XPlode-Befehl
|
|
;;; global oder individuell angesprochen werden. Wird URSPRUNG global
|
|
;;; gew„hlt, erscheint f�r alle betreffenden Objekte die Abfrage:
|
|
;;;
|
|
;;; All/Color/LAyer/LType/Inherit from parent block/<Explode>:
|
|
;;;
|
|
;;; Sollen die einzelnen Objekte individuell bearbeitet werden, muá f�r jedes
|
|
;;; einzelne Objekt eine Option aus dieser Auswahlzeile gew„hlt werden.
|
|
;;;
|
|
;;; Zum zweiten ist es mit dem URSPRUNG Befehl in AutoCAD nicht m”glich,
|
|
;;; bei der Zerlegung eines Blocks die Attribute der einzelnen Objekte zu
|
|
;;; ver„ndern. Ebenso ist es nicht m”glich, die Attribute einzelner Objekte
|
|
;;; des urspr�nglichen Block zu �bernehmen.
|
|
;;;
|
|
;;;
|
|
;;; ALL
|
|
;;;
|
|
;;; Hiermit k”nnen Farbe, Linientyp und Layer f�r neue Objekte festgelegt
|
|
;;; werden.
|
|
;;;
|
|
;;; COLOR
|
|
;;;
|
|
;;; Bei Anwahl dieser Option kann f�r die einzelnen Objekte eine neue Farbe
|
|
;;; ausgew„hlt werden:
|
|
;;;
|
|
;;; Neue Farbe f�r zerlegte Objekte
|
|
;;; Red/Yellow/Green/Cyan/Blue/Magenta/White/BYLayer/BYBlock/<cecolor>:
|
|
;;;
|
|
;;; Es kann jede Farbnummer zwischen 1 und 255 oder eine der angegebenen
|
|
;;; Standardfarben ausgew„hlt werden. "Cecolor" ist die aktuelle Farbe des
|
|
;;; Objekts, die von der Systemvariablen CECOLOR zugeordnet wird.
|
|
;;;
|
|
;;; LAYER
|
|
;;;
|
|
;;; Mit der Option LAYER kann der Name des Layers bestimmt werden, auf dem
|
|
;;; die einzelnen Objekte plaziert werden sollen:
|
|
;;;
|
|
;;; XPlode onto what layer? <clayer>:
|
|
;;;
|
|
;;; Der Name des Layers wird abgepr�ft, existiert er nicht, wird die Abfrage
|
|
;;; wiederholt. RETURN ohne weitere Eingabe w„hlt den aktuellen Layer aus.
|
|
;;;
|
|
;;; LTYPE
|
|
;;;
|
|
;;; LTYPE gibt eine Liste der geladenen Linientypen der aktuellen Zeichnung
|
|
;;; aus und erwartet die Auswahl eines Linientyps. Hier muá (leider) die
|
|
;;; volle Bezeichnung des Linientyps eingegeben werden, es sei denn, der
|
|
;;; aktuelle Linientyp wird mit RETURN akzeptiert.
|
|
;;;
|
|
;;; Choose from the following list of linetypes.
|
|
;;; CONTinuous/...others.../<CONTINUOUS>:
|
|
;;;
|
|
;;; INHERIT
|
|
;;;
|
|
;;; šbernahme bedeutet in Bezug auf den urspr�nglingen Block, daá die
|
|
;;; Attribute des zu zerlegenden Blocks ohne weitere Auswahloption auf die
|
|
;;; einzelnen Objekte des Blocks �bertragen werden.
|
|
;;;
|
|
;;; URSPRUNG
|
|
;;;
|
|
;;; Diese Option l”st den URSPRUNG Befehl mit den aktuellen Einstellungen
|
|
;;; f�r alle momentan ausgew„hlten Objekte aus
|
|
;;;
|
|
;;; --------------------------------------------------------------------------;
|
|
|
|
;;; ------------------------ INTERNES FEHLERVERHALTEN ------------------------;
|
|
|
|
(defun xp_err (s) ; Ereignet sich ein Fehler (z.B. CTRL-C)
|
|
; bei der Ausf�hrung dieses Befehls...
|
|
(if (/= s "Funktion abgebrochen")
|
|
(princ (strcat "\nFehler: " s))
|
|
)
|
|
(if xp_oce (setvar "cmdecho" xp_oce)) ; urspr�nglichen cmdecho-Wert einsetzen
|
|
(setq *error* olderr) ; urspr�ngliche Fehlerroutine einsetzen
|
|
(princ)
|
|
)
|
|
|
|
;;; ---------------------------- ALLGEMEINE FUNKTION -------------------------;
|
|
|
|
(defun xp_val (n e f)
|
|
(if f ; falls f zutrifft, stellt e eine Objektliste dar.
|
|
(cdr (assoc n e))
|
|
(cdr (assoc n (entget e)))
|
|
)
|
|
)
|
|
|
|
;;; ------------------- OBJEKT FšR URSPRUNG BEREITSTELLEN --------------------;
|
|
;;; ---------------------------- HAUPTPROGRAMM -------------------------------;
|
|
|
|
(defun explode ( / oce ohl e0 en e1 s0)
|
|
|
|
;; Versionsnummer. Bei Ab„nderung bitte lokal zur�cksetzen.
|
|
(setq xp_ver "0.10")
|
|
|
|
;;(setq xp_oer *error*
|
|
;; *error* xp_err)
|
|
(setq xp_oce (getvar "cmdecho")) ; cmdecho-Wert sichern
|
|
(setvar "cmdecho" 0) ; cmdecho abschalten
|
|
|
|
(graphscr)
|
|
(princ (strcat "\nXPlode, Version " xp_ver ", (c) 1990 by Autodesk, Inc. "))
|
|
|
|
(princ "\nObjekte w„hlen, die XPloded werden sollen. ")
|
|
(setq ss (ssget))
|
|
|
|
(if ss
|
|
(progn
|
|
;; Aussortieren von Objekten die nicht in URSPRUNG einbezogen werden...
|
|
(setq ss (xp_sxe)) ; DLine_Sort_Xplodable_Entities
|
|
|
|
;; XPlode Individuell oder Global.
|
|
|
|
(if (> (sslength ss) 0)
|
|
(progn
|
|
(if (> (sslength ss) 1)
|
|
(progn
|
|
(initget "Individuell Global")
|
|
(setq ans (getkword "\n\nXPlode Individuell/<Global>: "))
|
|
)
|
|
(setq ans "Global")
|
|
)
|
|
|
|
|
|
(cond
|
|
((= ans "Individuell")
|
|
(setq sslen (sslength ss)
|
|
j 0
|
|
)
|
|
(while (< j sslen)
|
|
(setq temp (ssname ss j)
|
|
prmpt T
|
|
)
|
|
|
|
(redraw temp 3)
|
|
(setq typ (xp_gxt))
|
|
(xp_xpe temp typ)
|
|
(redraw temp 4)
|
|
(setq j (1+ j))
|
|
)
|
|
)
|
|
(T
|
|
(setq sslen (sslength ss)
|
|
j 0
|
|
ans "Global"
|
|
prmpt T
|
|
)
|
|
(setq typ (xp_gxt))
|
|
(while (< j sslen)
|
|
(setq temp (ssname ss j))
|
|
(xp_xpe temp typ)
|
|
(setq j (1+ j))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(if xp_oce (setvar "cmdecho" xp_oce)) ; urspr�nglichen cmdecho-Wert einsetzen
|
|
(setq *error* xp_err) ; urspr�ngliche Fehlerroutine einsetzen
|
|
(prin1)
|
|
)
|
|
;;;
|
|
;;; Alle Objekte aussortieren, die in die Zerlegung mit einbezogen werden
|
|
;;; sollen. Bitte beachten, daá bei Einf�gen von Bl”cken die X-, Y- und
|
|
;;; Z-GrӇenfaktoren gleich sind.
|
|
;;;
|
|
;;; xp_sxe == DLine_Sort_Xplodable_Entities
|
|
;;;
|
|
(defun xp_sxe (/ temp bad)
|
|
|
|
(setq sslen (sslength ss)
|
|
j 0
|
|
ss1 (ssadd)
|
|
)
|
|
(while (< j sslen)
|
|
(setq temp (ssname ss j))
|
|
(setq j (1+ j))
|
|
(if (member (xp_val 0 temp nil) '("INSERT" "DIMENSION" "POLYLINE"))
|
|
(if (= (xp_val 0 temp nil) "INSERT")
|
|
(if (and (= (xp_val 41 temp nil) (xp_val 42 temp nil))
|
|
(= (xp_val 41 temp nil) (xp_val 43 temp nil))
|
|
)
|
|
(ssadd temp ss1)
|
|
)
|
|
(ssadd temp ss1)
|
|
)
|
|
)
|
|
)
|
|
(setq sslen (sslength ss)
|
|
bad (sslength ss1)
|
|
)
|
|
(princ "\n")
|
|
(princ sslen)
|
|
(princ " Objekte gefunden. ")
|
|
(if (> (- sslen bad) 0)
|
|
(progn
|
|
(princ (- sslen bad))
|
|
(princ " ung�ltig. ")
|
|
)
|
|
)
|
|
ss1
|
|
)
|
|
;;;
|
|
;;; Art der Zerlegung bestimmen.
|
|
;;;
|
|
;;; xp_gxt == XPlode_Get_Xplode_Type
|
|
;;;
|
|
(defun xp_gxt (/ temp)
|
|
|
|
(initget "Alles Farbe LAyer LType šbernehmen Zerlegen")
|
|
(setq temp (getkword
|
|
"\n\nAlles/Farbe/LAyer/LType/šbernehmen vom �berg. Block/<Zerlegen>: "))
|
|
|
|
(if (or (= temp "") (null temp))
|
|
(setq temp "Zerlegen")
|
|
)
|
|
temp
|
|
)
|
|
;;;
|
|
;;; Ein Objekt in seine Einzelteile zerlegen.
|
|
;;;
|
|
;;; xp_xpe == XPlode_XPlode_Entity
|
|
;;;
|
|
(defun xp_xpe (ent typ / )
|
|
|
|
(cond
|
|
((= typ "Alles")
|
|
(if prmpt
|
|
(progn
|
|
(setq color (xp_scn))
|
|
(setq ltype (xp_slt))
|
|
(setq layer (xp_sla))
|
|
(setq prmpt nil)
|
|
)
|
|
)
|
|
|
|
(xp_xfa)
|
|
(if (or (= ans "Individuell") (= j (1- sslen)))
|
|
(progn
|
|
(if (and (> sslen 1) (= ans "Global"))
|
|
(princ "\nObjekte ")
|
|
(princ "\nObjekt ")
|
|
)
|
|
(princ (strcat "zerlegt my Farbe von "
|
|
(if (= (type color) 'INT) (itoa color) color) ", "
|
|
"Linietyp von " ltype ", "
|
|
"und Layer " layer "."))
|
|
)
|
|
)
|
|
)
|
|
((= typ "Farbe")
|
|
(if prmpt
|
|
(progn
|
|
(setq color (xp_scn))
|
|
(setq ltype (getvar "celtype"))
|
|
(setq layer (getvar "clayer"))
|
|
(setq prmpt nil)
|
|
)
|
|
)
|
|
|
|
(xp_xfa)
|
|
(if (or (= ans "Individuell") (= j (1- sslen)))
|
|
(progn
|
|
(if (and (> sslen 1) (= ans "Global"))
|
|
(princ "\nObjekte ")
|
|
(princ "\nObjekt ")
|
|
)
|
|
(princ (strcat "zerlegt mit Farbe von "
|
|
(if (= (type color) 'INT) (itoa color) color) "."))
|
|
)
|
|
)
|
|
)
|
|
((=
|
|
typ "LAyer")
|
|
(if prmpt
|
|
(progn
|
|
(setq color (getvar "cecolor"))
|
|
(setq ltype (getvar "celtype"))
|
|
(setq layer (xp_sla))
|
|
(setq prmpt nil)
|
|
)
|
|
)
|
|
|
|
(xp_xfa)
|
|
(if (or (= ans "Individuell") (= j (1- sslen)))
|
|
(progn
|
|
(if (and (> sslen 1) (= ans "Global"))
|
|
(princ "\nObjekte ")
|
|
(princ "\nObjekt ")
|
|
)
|
|
(princ (strcat "zerlegt auf Layer " layer "."))
|
|
)
|
|
)
|
|
)
|
|
((= typ "LType")
|
|
(if prmpt
|
|
(progn
|
|
(setq color (getvar "cecolor"))
|
|
(setq ltype (xp_slt))
|
|
(setq layer (getvar "clayer"))
|
|
(setq prmpt nil)
|
|
)
|
|
)
|
|
|
|
(xp_xfa)
|
|
(if (or (= ans "Individuell") (= j (1- sslen)))
|
|
(progn
|
|
(if (and (> sslen 1) (= ans "Global"))
|
|
(princ "\nObjekte ")
|
|
(princ "\nObjekt ")
|
|
)
|
|
(princ (strcat "zerlegt mit Linientyp von " ltype "."))
|
|
)
|
|
)
|
|
)
|
|
((= typ "šbernehmen")
|
|
(xp_iap ent)
|
|
)
|
|
(T
|
|
(command "ursprung" (xp_val -1 ent nil))
|
|
)
|
|
)
|
|
)
|
|
;;;
|
|
;;; Farb-, Linientyp- und Layerattribute nach dem Zerlegen festlegen.
|
|
;;;
|
|
;;; xp_xea == XPlode_Xplode_Force_All
|
|
;;;
|
|
(defun xp_xfa ()
|
|
|
|
(setq e0 (entlast))
|
|
(setq en (entnext e0))
|
|
(while (not (null en)) ; Letztes Objekt ermitteln
|
|
(setq e0 en)
|
|
(setq en (entnext e0))
|
|
)
|
|
|
|
(command "ursprung" (xp_val -1 ent nil)) ; Objekt in Einzelteile zerlegen
|
|
|
|
(setq s0 (ssadd))
|
|
|
|
(while (entnext e0)
|
|
(ssadd (setq e0 (entnext e0))
|
|
s0
|
|
)
|
|
)
|
|
(command "eig„ndr" s0 "" ; Objekte mit gew�nschter Layerfarbe und
|
|
"f" color ; Linientyp versehen ohne Beachtung ihrer
|
|
"lt" ltype ; ihrer Ausdehnungsrichtung.
|
|
"la" layer
|
|
""
|
|
)
|
|
)
|
|
;;;
|
|
;;; Attribute von urspr�nglichem Block �bernehmen (falls VONBLOCK)
|
|
;;;
|
|
;;; xp_iap == XPlode_Inherit_Attributes_from_Parent
|
|
;;;
|
|
(defun xp_iap (t1 / t1cl t1lt t1ly s0ly s0lt s0cl t0e)
|
|
(setq t0 (entlast))
|
|
(setq tn (entnext t0))
|
|
(while (not (null tn)) ; Letztes Objekt suchen
|
|
(setq t0 tn)
|
|
(setq tn (entnext t0))
|
|
)
|
|
|
|
(setq t1cl (xp_val 62 t1 nil)) ; Blockattribute protokollieren
|
|
(setq t1lt (xp_val 6 t1 nil))
|
|
(setq t1ly (xp_val 8 t1 nil))
|
|
(command "ursprung" (xp_val -1 t1 nil)) ; Objekt in Einzelteile zerlegen
|
|
(setq s0ly (ssadd)) ; Blanko-Auswahlsatz f�r Layer einrichten
|
|
(setq s0lt (ssadd)) ; Žnderung von Linientyp und Farbe
|
|
(setq s0cl (ssadd))
|
|
(setq t0 (entnext t0))
|
|
(while t0 ; Zerlegte Objekte sichern
|
|
(setq t0e (entget t0)) ; und Auswahls„tze einrichten
|
|
|
|
(if (= (xp_val 62 t0e T) "VONBLOCK") (ssadd t0 s0cl))
|
|
(if (= (xp_val 6 t0e T) "VONBLOCK") (ssadd t0 s0lt))
|
|
(if (= (xp_val 8 t0e T) "0") (ssadd t0 s0ly))
|
|
(setq t0 (entnext t0))
|
|
)
|
|
(if (> (sslength s0cl) 0) ; falls Auswahlsatz kein Blanko...
|
|
(command "eig„ndr" s0cl "" ; Farbe der zerlegten Objekte (festgelegt
|
|
"f" t1cl "") ; durch VONBLOCK) in Farbe des urspr�ng-
|
|
; lichen Blocks um„ndern
|
|
)
|
|
(if (> (sslength s0lt) 0)
|
|
(command "eig„ndr" s0lt "" ; Linientyp der zerlegten Objekte (festge-
|
|
"lt" t1lt "") ; legt durch VONBLOCK) in Linientyp des
|
|
; urspr�nglichen Blocks um„ndern
|
|
)
|
|
(if (> (sslength s0ly) 0)
|
|
(command "eigndr" s0ly "" ; Linientyp der zerlegten Objekte (festge-
|
|
"la" t1ly "") ; legt durch VONBLOCK) in Linientyp des
|
|
; urspr�nglichen Blocks um„ndern.
|
|
)
|
|
(if (or (= ans "Individuell") (= j (1- sslen)))
|
|
(progn
|
|
(if (and (> sslen 1) (= ans "Global"))
|
|
(princ "\nObjekte ")
|
|
(princ "\nObjekt ")
|
|
)
|
|
(princ "zerlegt.")
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;
|
|
;;; Farbe der in Einzelteile zerlegten Objekte bestimmen.
|
|
;;;
|
|
;;; xp_scn == XPlode_Set_Color_Number
|
|
;;;
|
|
(defun xp_scn ()
|
|
(setq arg 257)
|
|
(while (> arg 256)
|
|
(initget 2 "Rot GElb GR�n Cyan Blau Magenta Weiá VONLayer VONBlock")
|
|
(setq arg (getint (strcat
|
|
"\n\nNeue Farbe f�r zerlegte Objekte. "
|
|
"\nRot/GElb/GR�n/Cyan/Blau/"
|
|
"Magenta/Weiá/VONLayer/VONBlock/<"
|
|
(if (= (type (getvar "cecolor")) 'INT)
|
|
(itoa (getvar "cecolor"))
|
|
(getvar "cecolor")
|
|
)
|
|
">: ")))
|
|
(cond
|
|
((= arg "VONLayer") (setq arg 0))
|
|
((= arg "Rot") (setq arg 1))
|
|
((= arg "GElb") (setq arg 2))
|
|
((= arg "GR�n") (setq arg 3))
|
|
((= arg "Cyan") (setq arg 4))
|
|
((= arg "Blau") (setq arg 5))
|
|
((= arg "Magenta") (setq arg 6))
|
|
((= arg "Weiá") (setq arg 7))
|
|
((= arg "VONBlock") (setq arg 256))
|
|
(T
|
|
(if (= (type arg) 'INT)
|
|
(if (> arg 255)
|
|
(progn
|
|
(princ "\nFarbnummer muá zwischen 1 und 255 liegen. ")
|
|
(setq arg 257) ; kludge
|
|
)
|
|
)
|
|
(setq arg (if (= (type (setq arg (getvar "cecolor"))) 'INT)
|
|
(getvar "cecolor")
|
|
(cond
|
|
((= arg "VONLAYER") (setq arg 0))
|
|
((= arg "VONBLOCK") (setq arg 256))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(cond
|
|
((= arg 0) (setq arg "VONBLOCK"))
|
|
((= arg 256) (setq arg "VONLAYER"))
|
|
)
|
|
arg
|
|
)
|
|
;;;
|
|
;;; Einen Linientyp aus den geladenen Linientypen ausw„hlen.
|
|
;;;
|
|
;;; xp_slt == XPlode_Set_Line_Type
|
|
;;;
|
|
(defun xp_slt ()
|
|
(princ "\n\nW„hlen Sie aus der folgenden Linientypliste. ")
|
|
(tblnext "ltype" T)
|
|
(setq xp_lta "CONTINUOUS,CONT VONLayer VONBlock"
|
|
xp_ltb "VONBlock/VONLayer/CONTinuous")
|
|
|
|
(while (setq xp_lt (cdr(assoc 2 (tblnext "ltype"))))
|
|
(setq xp_lta (strcat xp_lta " " xp_lt)
|
|
xp_ltb (strcat xp_ltb "/" xp_lt))
|
|
)
|
|
(initget xp_lta)
|
|
(princ (strcat
|
|
"\nNeuer Linientypname. \n" xp_ltb "/<"
|
|
(getvar "celtype") "> : "))
|
|
(setq xp_nln (getkword) )
|
|
(if (or (= xp_nln nil) (= xp_nln ""))
|
|
(setq xp_nln (getvar "celtype"))
|
|
)
|
|
xp_nln
|
|
)
|
|
;;;
|
|
;;; Einen Layer angeben - falls einer vorhanden.
|
|
;;;
|
|
;;; xp_sla == XPlode_Set_LAyer
|
|
;;;
|
|
(defun xp_sla (/ temp)
|
|
(while (null temp)
|
|
(initget 1)
|
|
(setq temp (getstring (strcat
|
|
"\n\nAuf welchen Layer zerlegen ? <" (getvar "clayer") ">: ")))
|
|
(if (or (= temp "") (null temp))
|
|
(setq temp (getvar "clayer"))
|
|
(if (not (tblsearch "layer" temp))
|
|
(progn
|
|
(princ "\nUng�ltiger Layername. ")
|
|
(setq temp nil)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
temp
|
|
)
|
|
|
|
;;; --------------------------------------------------------------------------;
|
|
(defun c:xp () (explode))
|
|
(defun c:xplode () (explode))
|
|
(princ
|
|
"\n\tC:XPLode geladen. Funktion mit XP oder XPLODE starten.")
|
|
(prin1)
|
|
|