;PRG nennt Attribute von Geräteblöcken um
;******************************************************************************
;Routine durchläuft Datenbank bis Attribut korrekt ist und listet alttext aus
(defun lies-mal (/ attrib-name vorbei)
  (setq unter-blk (entget blk))
  (setq unter-blk (cdr (assoc -1 unter-blk)));enthält EED-Name
  (setq unter-blk (entnext unter-blk));enthält EED-Name des Unterelement
  (setq unter-blk-datenb (entget unter-blk));enthält Block-Attribut-Element NAME-DER-VERTEILUNG***********
  (setq attrib-name (cdr (assoc 2 unter-blk-datenb)));enthält Attribut-Name
  (if (= attrib-name attrib)
    (progn
      (setq alttext (cdr (assoc 1 unter-blk-datenb)))
      );progn ende
    (while (/= attrib-name attrib)
      (setq unter-blk (entnext unter-blk))
      (setq unter-blk-datenb (entget unter-blk))
      (setq attrib-name (cdr (assoc 2 unter-blk-datenb)))
      (setq vorbei (cdr (assoc 0 unter-blk-datenb)))
      (if (= attrib-name attrib)
	(progn
	  (setq alttext (cdr (assoc 1 unter-blk-datenb)))
	  (setvar "cmdecho" 0)
	  (setvar "cmdecho" 1)
	  );progn ende
	);if ende
      (if (= vorbei "SEQEND");vorbereitung Schleifenende
	(progn
	  (setq attrib-name attrib)
	  (setq alttext nil)
	  );progn
	);seqend Schleifenende
      );while ende
    );if ende
  );defun Ende
;******************Attrib wird umgebaut********************************
(defun u:devisemacher ()
  ;hier sollen die Zahlen entfernt werden
  (setq neutext "")
  (repeat (strlen alttext)
    (setq textteil (substr alttext 1 1))
    (if (and (/= textteil "0") (/= textteil "1") (/= textteil "2") (/= textteil "3") (/= textteil "4") (/= textteil "5") (/= textteil "6") (/= textteil "7") (/= textteil "8") (/= textteil "9"))
      (setq neutext (strcat neutext textteil))
      );if
    (setq alttext (substr alttext 2))
    );repeat
;************************
  ;block wird umgebaut
  (setq unter-blk (entget blk))
  (setq blkname (cdr (assoc 2 unter-blk)))
  (setq blk-aws2 (tblsearch "BLOCK" blkname))
  (setq unter-blk-datenb (entget (cdr (assoc -2 blk-aws2))))
  (setq attribut-name (cdr (assoc 2 unter-blk-datenb)));enthält Attribut-Name
  (if (= attribut-name "DEVISE")
    (progn
      (setq unter-blk-datenb (subst (cons 2 neutext) (assoc 2 unter-blk-datenb) unter-blk-datenb))
      (setq unter-blk-datenb (subst (cons 3 "INTAK") (assoc 3 unter-blk-datenb) unter-blk-datenb))
      (entmod unter-blk-datenb)
      );progn
    (while (/= attribut-name "DEVISE")
      (setq unter-blk-datenb (cdr (assoc -1 unter-blk-datenb)))
      (setq unter-blk-datenb (entnext unter-blk-datenb))
      (if (/= unter-blk-datenb nil)
	(progn
	  (setq unter-blk-datenb (entget unter-blk-datenb))
	  (setq attribut-name (cdr (assoc 2 unter-blk-datenb)))
	  (setq vorbei (cdr (assoc 0 unter-blk-datenb)))
	  (if (= attribut-name "DEVISE")
	    (progn
	      (setq unter-blk-datenb (subst (cons 2 neutext) (assoc 2 unter-blk-datenb) unter-blk-datenb))
	      (setq unter-blk-datenb (subst (cons 3 "INTAK") (assoc 3 unter-blk-datenb) unter-blk-datenb))
	      (entmod unter-blk-datenb)
	      (entupd (cdr (assoc -1 (entget unter-blk-datenb))))
	      );progn Ende
	    );if Ende
	  (if (= vorbei "SEQEND");Vorbereitung Schleifenende
	    (progn
	      (setq attribut-name attribut)
	      );progn
	    );if SEQEND Schleifenende
	  );progn Ende
	(setq attribut-name "DEVISE")
	);if Ende
      );while
    );if Ende
;;;  (setq unter-blk (entget blk))
;;;  (setq unter-blk (entget (entnext (cdr (assoc -1 unter-blk)))))
;;;  (cdr (assoc 7 unter-blk))
;;;    (setq unter-blk (subst (cons 2 neutext) (assoc 2 unter-blk) unter-blk))
;;;    (entmod unter-blk)
;;;    (entupd (cdr (assoc -1 unter-blk)))
  );defun
;***************Start Hauptroutine**********************
(defun c:zdf_blkattribname ()
  (vl-load-com)
  (setq blk-aws (ssget "X" '((0 . "INSERT"))))
  (setq position 0)
  (if (/= blk-aws nil) 
    (repeat (sslength blk-aws)
      (setq blk (ssname blk-aws position))
      (setq unter-blk (entget blk))
      (if (= (cdr (assoc 66 unter-blk)) 1);attrib folgt
	(if (and (= (cdr (assoc 2 (entget (entnext (cdr (assoc -1 unter-blk)))))) "DEVISE") (/= (cdr (assoc 2 unter-blk)) "Blockbeschriftung"));1. Attrib darf nicht DEVISE sein un der BLK darf nicht Blockbeschriftung sein
	  (progn
;;;	    (setq unter-blk (entget (entnext (cdr (assoc -1 unter-blk)))))
	    (setq attrib "DEVISE")
	    (lies-mal);subroutine liest Attribinhalt aus
	    (u:devisemacher)
	    );progn
	  );if
	);if
      (setq position (+ position 1))
      );repeat
    );if
  );defun