;;; ***********************************************************************
;;; * ATT-CLONE dient zum Übertragen von Attributwerten eines Blockes auf *
;;; * beleibige andere Blöcke.                                            *
;;; * Bei identischen "Feldnamen" (also AttributNAMEN) wird der Wert des  *
;;; * Quellblocks als Wert des zu klickenden Zielblocks eingetragen.      *
;;; * Versuch's mit der dem Original-Zip Archiv beiliegenden              *
;;; * "Test-Att-Clone.dwg"                                                *
;;; *                                                                     *
;;; * Written by Marc Scherer in 2002                                     *
;;; *                                                                     *
;;; * Anregungen/Kritik an "marc.scherer@zvo.com"                         *
;;; *                                                                     *
;;; * Dieses Programm folgt der "Better than Nothing" Philosophie des     *
;;; * Leonid Nemirovsky: (http://home.pacifier.com/~nemi/)                *
;;; * Zitat:                                                              *
;;; * The AutoLISP programs you are about to check - are NOT shareware    *
;;; * or freeware. They are BTN - Better Than Nothing Software.           *
;;; * You can freely use them in any way you choose.                      *
;;; * Just remember one thing.......                                      *
;;; * If they do not perform the way you expect -                         *
;;; *                                it is still BETTER THAN NOTHING !!!  *
;;; * I wrote those programs for my every day work.                       *
;;; * Some of them are more useful, some - are SO SO.                     *
;;; * ... Good Luck !                                                     *
;;; ***********************************************************************

;### Funktioniert nur mit gleichem Attributnamen ###

;;; Funktionsaufruf zum Pinselübertragen
;;; Überträgt Attributwerte von einem Quellblock auf beliebig
;;; viele Zielblöcke
(defun C:ATT-CLONE (/ ATT-LST CHK OBJ OBJ-DATA)
  (while
    (/= (if (setq OBJ
                   (car
                     (entsel
                       "\nBitte Quellblock für Attributwert-Übertragung wählen: "
                     ) ;_ end of entsel
                   ) ;_ end of car
            ) ;_ end of setq
          (progn
            (setq CHK (cdr (assoc 0 (setq OBJ-DATA (entget OBJ)))))
            (if (/= CHK "INSERT")
              (princ "\nKein BLOCK-Objekt geklickt, versuch's noch einmal...")
            ) ;_ end if
            CHK
          ) ;_ end of progn
          (princ "\nNICHTS geklickt, versuch's noch einmal...")
        ) ;_ end of if
        "INSERT"
    ) ;_ end of /=
  ) ;_ end of while
  (if OBJ-DATA
    (progn
      (if (CHK-ENT OBJ)
        (progn
          (setq ATT-LST (ALL-BL-TXT OBJ))
          (if (not ATT-LST)
            (princ
              "\nQuell-Block enthält keinerlei Attributsdaten... Funktionsende !"
            ) ;_ end princ
            (progn
              ;(while (setq OBJ
							(setq OBJ
                            (car
                              (entsel
                                "\nBitte Zielblock für Attributwert-Übertragung wählen (R.Klick=Ende): "
                              ) ;_ end of entsel
                            ) ;_ end of car
                     ) ;_ end of setq
                (if (CHK-ENT OBJ)
                  (progn
                    (if (assoc 66 (entget OBJ))
                      (progn
                        (foreach ELEM ATT-LST
														(if (wcmatch (strcase(car ELEM)) (strcase "BEZ1,BEZ2")) ;Beispiel-Filter mit Sicherheits-strcase
														(princ (ED-ATT ELEM OBJ))
														)
                        ) ;_ end foreach
                      ) ;_ end progn
                      (princ "\nZielblock enthält keine Attribute !")
                    ) ;_ end if
                  ) ;_ end progn
                  (princ "\nObjekt war KEIN Block oder UNGÜLTIG!")
                ) ;_ end of if
              ) ;_ end of while              
            ;) ;_ end progn
          ) ;_ end if
        ) ;_ end progn
        (princ "\nObjekt war KEIN Block oder UNGÜLTIG!")
      ) ;_ end of if
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end defun


;;; Funktion checkt, ob Objekt ein regulärer Block oder'n Xref
;;; ist, bzw. ob's überhaupt 'n Insert ist...
;;; Rückgabe: Wenn kein Block, dann nil, ansonsten Ausgabe wie Eingabe
(defun CHK-ENT (ENT / ENT-DATA)
  (if (= (type ent) 'ENAME)
    (setq ent-data (entget ent))
    (setq ent-data (entget (car ent)))
  ) ;_ end of if
  (cond
    ((= (cdr (assoc 0 ENT-DATA))
        "INSERT"
     ) ;_ end =
     (if
       (>= (cdr (assoc 70 (tblsearch "BLOCK" (cdr (assoc 2 ENT-DATA))))
           ) ;_ end cdr
           4
       ) ;_ Wenn T dann Xref!!!
        (progn
          (princ
            "\nGeklicktes Objekt war ein XREF. Versuch's noch mal..."
          ) ;_ end princ
          (setq ENT NIL)
        ) ;_ end progn
        (setq ENT ENT)
     ) ;_ end if
    )
    (t
     (princ
       "\nGeklicktes Objekt war KEIN Block. Versuch's noch mal..."
     ) ;_ end princ
     (setq ENT NIL)
    )
  ) ;_ end cond
  ENT
) ;_ end defun


;;; Funktion tauscht Attributwerte aus.
;;; Zu übergeben ist eine cons List aus
;;; ("ATTBEZEICHNUNG" . "NEUER TEXTWERT")
;;; sowie der Elementname des Blocks, dessen Werte verändert werden sollen
(defun ED-ATT (CHANGELST OBJNAME / ATTNAME BACK CHK OBJDATA TXTWRT)
  (setq ATTNAME (car CHANGELST)
        TXTWRT  (cdr CHANGELST)
        OBJDATA (entget OBJNAME)
  ) ;_ end of setq
  (while (/= (cdr (assoc 0 OBJDATA)) "SEQEND")
    (setq OBJDATA (entget (entnext (cdr (assoc -1 OBJDATA)))))
    (if (eq (cdr (assoc 2 OBJDATA)) ATTNAME)
      (progn
        (setq OBJDATA (subst (cons 1 TXTWRT) (assoc 1 OBJDATA) OBJDATA))
        (entmod OBJDATA)
        (setq CHK (entupd OBJNAME)
              OBJDATA (list (cons 0 "SEQEND"))
        ) ;_ end setq
      ) ;_ end progn
    ) ;_ end if
  ) ;_ end while
  (if CHK
    (setq BACK (strcat "\nWert: \""      TXTWRT
                       "\" für: \""      ATTNAME
                       "\" eingesetzt..."
                      ) ;_ end strcat
    ) ;_ end of setq
    (setq BACK
           (strcat "\nFeld: \"" ATTNAME "\" im Zielblock nicht vorhanden...")
    ) ;_ end of setq
  ) ;_ end of if
  BACK
) ;_ 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
(defun ALL-BL-TXT (ENAME / EDATA RETVAL)
  (setq RETVAL '() ;_ Liste initialiseren
        EDATA  (entget ENAME)
  ) ;_ end setq
  (if (assoc 66 EDATA) ;_ GC 66 fehlt, wenn Block keine Attrib's hat
    (progn
      (while (/= (cdr (assoc 0 EDATA)) "SEQEND") ;_ Solange die Sequenz nicht endet...
        (setq EDATA (entget (entnext (cdr (assoc -1 EDATA)))))
        (if (= (cdr (assoc 0 EDATA)) "ATTRIB")
          (setq RETVAL
                 (cons
                   (cons (cdr (assoc 2 EDATA)) (cdr (assoc 1 EDATA)))
                   RETVAL
                 ) ;_ end cons
          ) ;_ end setq
        ) ;_ end if
      ) ;_ end while
      (setq RETVAL (reverse RETVAL))
    ) ;_ end progn
  ) ;_ end if
  RETVAL
) ;_ end defun

(princ "\n\"ATT-CLONE\"->\"Pinselübertragung\" von Attribut-WERTEN...")

(princ)