;;;---------------------------------------------------------------------------;
;;;
;;; 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)