(IF SPECIAL
    (SPECIAL '(olde ptest cavar bell prna))
    (DEFUN SPECIAL (x) nil)
)
(DEFUN pstart (tit qust setv / xlen xpos xvar)
    (SETQ olde *ERROR*
	  *ERROR* (IF ptest NIL errhan)
	  cavar (APPEND '(("CLAYER")("CMDECHO"))
		    setv)
	  xlen (LENGTH cavar)
	  xpos 0
    )
    (REPEAT xlen
	(SETQ xvar (CAR (NTH xpos cavar))
	      cavar (SUBST (CONS xvar (GETVAR xvar))
			  (NTH xpos cavar) cavar)
	      xpos (1+ xpos)
	)
    )
    (SETVAR "CMDECHO" 0)
    (COMMAND "_undo" "_G")
    (GRAPHSCR)
    (PROMPT (STRCAT "\n***** " tit " *****\n\n  " qust))
    (PRINC)
)
(DEFUN pend (/ xpos xlen xvar)
    (IF cavar
	(PROGN
	    (COMMAND)
	    (COMMAND "_undo" "_E")
	    (SETQ xpos 1
		  xlen (LENGTH cavar)
	    )
	    (IF (/= (GETVAR "CLAYER") (CAAR cavar))
			(COMMAND "_LAYER" "_SE" (CDAR CAVAR) "")
	    )
	    (REPEAT (1- xlen)
		(SETQ xvar (NTH xpos cavar)
		      xpos (1+ xpos)
		)
		(SETVAR (CAR xvar)(CDR xvar))
	    )
	)
    )
    (IF olde (SETQ *ERROR* olde))
    (PRINC)
)
(DEFUN errhan (em)
    (IF (= em "Function cancelled")
	(PRINC)
	(PRINC em)
    )
    (GRTEXT)
    (COMMAND)
    (COMMAND)
    (pend)
)
(DEFUN ques (dial defa)                         ;Std Abfrage
    (IF defa
	(PROGN
	    (INITGET 1 "Yes No  Yes")
	    (= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
	)
	(PROGN
	    (INITGET 1 "Yes No  No")
	    (= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "Yes")
	)
    )
)
(DEFUN emsg (etxt)
    (IF (NOT bell)(PROMPT "\007"))
    (TERPRI)
    (PROMPT etxt)
    (TERPRI)
)
(DEFUN ques (dial defa)                         ;Std Abfrage
   (IF defa
      (PROGN
	 (INITGET 1 "Yes No  Yes")
	 (= (GETKWORD (STRCAT "\n" dial " Y/N <Y>: ")) "No")
      )
      (PROGN
	 (INITGET 1 "Yes No  No")
	 (= (GETKWORD (STRCAT "\n" dial " Y/N <N>: ")) "Yes")
      )
   )
)
(DEFUN renv (envn prnn / penv)
    (IF (SETQ penv (GETENV envn))
	(EVAL (STRCAT penv "" prnn))
	(EVAL prnn)
    )
)
(DEFUN C:PRG (/ nprg cprg prna)
    (SETQ nprg (GETSTRING)
	  cprg (STRCAT "C:" nprg)
	  prna (renv "ACADLSP" nprg)
    )
    (IF (NULL (EVAL (READ cprg)))
	(PROGN
	    (PRINC " loading...!\n")
	    (COND
		((FINDFILE (STRCAT prna ".BI4"))
			     (LOAD prna ".BI4"))
		((FINDFILE (STRCAT prna ".BI2"))
			     (LOAD prna ".BI2"))
		((FINDFILE (STRCAT prna ".LSP"))
			     (LOAD prna ".LSP"))
		( T        (emsg "File not found"))
	    )
	)
    )
    (PRINC)
)
(DEFUN C:ed (/ prnn)
    (IF (NULL prna)
	(SETQ prna "")
    )
    (SETQ prnn (GETSTRING
		    (STRCAT "Programname  <" prna ">: ")))
    (IF (AND (= (STRLEN prna) 0)(= (STRLEN prnn) 0))
	(emsg "Name not allowed...")
	(PROGN
	    (IF (> (STRLEN prnn) 0)
		(SETQ prna (renv "ACADLSP" prnn))
	    )
	    (COMMAND "SHELL" (STRCAT "ED " prna ))
	    (INITGET 1 "Yes No  Yes")
	    (IF (NOT (ques "Load the program" T))
		(LOAD prna)
	    )
	)
    )
    (PRINC)
)
;----------- Block einfuegen mit Layergenerierung ----2.8.92 AW
; KEINE DREHMOEGLICHKEIT !!!
(DEFUN c:symplac ( / einp); / einp ebene symname)
  (SETQ einp    (GETPOINT "\nInsert-Point: "))
  (COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
  (COMMAND "_insert" symname einp "" "" "0")
)
;----------- Block einfuegen mit Layergenerierung ----14.8.92 AW
; MIT DREHMOEGLICHKEIT !!!
(DEFUN c:sympl_dr ( / einp); / einp ebene symname)
  (SETQ einp    (GETPOINT "\nInsert-Point: "))
  (COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
  (COMMAND "_insert" symname einp "" "" pause)
)
;----------- Block einfuegen mit Layergenerierung ---16.9.93 AW
; MIT DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr2 ( / einp drehung groesse)
   (setq groesse "1")
   (SETQ einp    (GETPOINT "\nInsert-Point: "))
   (SETQ drehung (GETSTRING "\nRotation: "))
   (SETQ groesse (GETSTRING "\nScale: "))
   (COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
   (COMMAND "_insert" symname einp groesse groesse drehung)
   (COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung ---21.11.93 AW
; ABFRAGE: SKALIERUNG/ DREHMOEGLICHKEIT UND URSPRUNG NACH DEM SETZEN !!!
(DEFUN c:sympldr1 ( / einp drehung)
   (SETQ einp    (GETPOINT "\nInsert-Point: "))
   (SETQ drehung (GETSTRING "\nRotation: "))
   (COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
   (COMMAND "_insert" symname einp "" "" drehung)
   (COMMAND "_explode" "_last")
)
;----------- Block einfuegen mit Layergenerierung und Skalierung ---12.2.93 AW
(DEFUN c:sym_scal ( / einp p1 p2); / einp ebene symname)
  (SETQ einp    (GETPOINT "\nInsert-Point: "))
  (SETQ p1      (GETREAL "\nX-Scale: "))
  (SETQ p2      (GETREAL "\nY-Scale: "))
  (COMMAND "_LAYER" "_M" ebene "_co" eb_farbe "" "")
  (COMMAND "_insert" symname einp p1 p2 "0")
)

;------------ Farbe aendern - AUFRUF aus POP2--------------------------
(DEFUN c:alt_farb ( / sst_obj neuefarb)
   (setq sst_obj (ssget) neuefarb (getstring "\nNew-Color: "))
   (command "_change" sst_obj "" "_prop" "_co" neuefarb "")
)
;--------------------------------------------------------------------

(defun block-op (PT0 szoeg auswahl-satz / komponente1 komponente2 
		   seconds element-name gefunden)
  ;------------------
  ; Block definieren
  ;-----------------------------------------------------------
  ;           PT0     - Origin der Baugruppe
  ;           szoeg   - Einfuegewinkel
  ;  auswahl-satz     - Elemente des Blockes in Auswahlsatz   
  ;------------------------------------------------------------
  (setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
		    (itoa (abs (fix (caddr PT0))))))
  (setq komponente2 szoeg)
  (setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
  (setq element-name (strcat komponente1 komponente2 seconds))
  (princ)
  (princ (strcat komponente1 "\n"))
  (princ (strcat komponente2 "\n"))
  (princ (strcat seconds "\n"))
  (princ)
  (princ (strcat "\n" element-name "\n"))
  (princ)
  (setq gefunden (tblsearch "block" element-name))
  (if (not gefunden)
     (progn
	 (princ)
	 (command "_block" element-name PT0 auswahl-satz "")
	 (command "_insert" element-name PT0 "" "" szoeg)
     )
     (alert "\nBlockname exists. You need HELP !")
  )
)

(defun c:bl-name (PT0 / komponente1 seconds)
; 14.4.94 
; Verwendung bei Baugruppen, deren Bestandteile aufgelistet
; werden m�ssen.
; Name eines Blockes gleich am Anfang des Programmes festlegen
; - die Einzelkomponenten werden in "C" mit diesem Wert belegt
; - dadurch ist eine eindeutige Gruppenzugeh"rigkeit m"glich
; 
  (setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
		    (itoa (abs (fix (caddr PT0))))))
  (setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
  (setq block-kennung (strcat komponente1 seconds))
  (princ)
)

(defun mach-block (PT0 szoeg auswahl-satz / komponente1 komponente2 
		   seconds element-name gefunden)
  ;------------------
  ; Block definieren
  ;-----------------------------------------------------------
  ;           PT0     - Origin der Baugruppe
  ;           szoeg   - Einfuegewinkel
  ;  auswahl-satz     - Elemente des Blockes in Auswahlsatz   
  ;------------------------------------------------------------
  (setq komponente1 (strcat (itoa (abs (fix (car PT0)))) (itoa (abs (fix (cadr PT0))))
		    (itoa (abs (fix (caddr PT0))))))
  (setq komponente2 szoeg)
  (setq seconds (substr (rtos (getvar "cdate") 2 9) 10 9))
  (setq element-name (strcat komponente1 komponente2 seconds))
  (princ)
  (princ (strcat komponente1 "\n"))
  (princ (strcat komponente2 "\n"))
  (princ (strcat seconds "\n"))
  (princ)
  (princ (strcat "\n" element-name "\n"))
  (princ)
  (setq gefunden (tblsearch "block" element-name))
  (if (not gefunden)
     (progn
	 (princ)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/a") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/b") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/c") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/artinr") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/beschr") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/menge") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/position") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/gruppe") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/etikette") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_insert" (strcat "*" lw "/acadsst/menu/aufloese") PT0 "" "")
	 (ssadd (entlast) auswahl-satz)
	 (command "_block" element-name PT0 auswahl-satz "")
	 (command "_insert" element-name PT0 "" "" szoeg)
     )
     (alert "\nBlockname exists. You need HELP !")
  )
)

;---------- Attribute aendern - Laenge,Endstueck,Artikel-Nr.--------------------
(defun ATTRIBUTE-AENDERN (M_POSITION M_ETIKETTE M_GRUPPE M_A M_B M_C M_ARTINR 
			 M_BESCHR M_MENGE M_AUFLOESE / objekt typ 
			 attribut-bezeichnung attribut-wert)
  (setq objekt (entlast))
  (while (not (equal 
		(cdr (assoc 0 (entget objekt)))
		"SEQEND"))
    (setq typ
      (cdr (assoc 0 (entget objekt))))
    (if
      (equal typ "ATTRIB")
      (progn
	(setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget objekt))))
	(setq ATTRIBUT-WERT        (cdr (assoc 1 (entget objekt))))

	(if (and (> (strlen M_POSITION) 0) (= ATTRIBUT-BEZEICHNUNG "POSITION"))
	     (entmod (subst (cons 1 M_POSITION) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_ETIKETTE) 0) (= ATTRIBUT-BEZEICHNUNG "ETIKETTE"))
	     (entmod (subst (cons 1 M_ETIKETTE) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_GRUPPE) 0) (= ATTRIBUT-BEZEICHNUNG "GRUPPE"))
	     (entmod (subst (cons 1 M_GRUPPE) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_A) 0) (equal ATTRIBUT-BEZEICHNUNG "A"))
	     (entmod (subst (cons 1 M_A) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_B) 0) (equal ATTRIBUT-BEZEICHNUNG "B"))
	     (entmod (subst (cons 1 M_B) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_C) 0) (equal ATTRIBUT-BEZEICHNUNG "C"))
	     (entmod (subst (cons 1 M_C) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_ARTINR) 0) (equal ATTRIBUT-BEZEICHNUNG "ARTINR"))
	     (entmod (subst (cons 1 M_ARTINR) (assoc 1 (entget objekt))
		     (entget objekt)))
	)
	(if (and (> (strlen M_BESCHR) 0) (equal ATTRIBUT-BEZEICHNUNG "BESCHR"))
	     (entmod (subst (cons 1 (strcat ATTRIBUT-WERT M_BESCHR))
		     (assoc 1 (entget objekt)) (entget objekt)))
	)
	(if (and (> (strlen M_MENGE) 0) (equal ATTRIBUT-BEZEICHNUNG "MENGE"))
	     (entmod (subst (cons 1 M_MENGE)
		     (assoc 1 (entget objekt)) (entget objekt)))
	)
	(if (and (> (strlen M_AUFLOESE) 0) (equal ATTRIBUT-BEZEICHNUNG "AUFLOESE"))
	     (entmod (subst (cons 1 M_AUFLOESE)
		     (assoc 1 (entget objekt)) (entget objekt)))
	)
      )  ; Ende ----progn
    )    ; Ende ----if
    (setq objekt (entnext objekt))
  )
  (setq objekt objekt)
)

;--- Objekt in der DB suchen und Attribut "ndern ---------------
; Parameter:
; ref         - handle
; bezeichnung - Attributbezeichnung, die gesucht ist
; wert        - neuer Wert
; addition    = 0 - Attributbezeichnung wird mit "wert" ersetzt
;               1 - Attributbezeichnung wird mit "wert" erg"nzt
;----------------------------------------------------------------
(defun suchen-aendern ( ref bezeichnung wert addition 
		      / typ attribut-bezeichnung attribut-wert)
  (redraw (handent ref) 3)
  (obj-suchen ref)
  (redraw (handent ref))
)

(defun obj-suchen (ref)
  (setq raus 0)
  (setq e (entnext))
  (while e
    (setq typ (cdr (assoc 0 (entget e))))
    (setq blockname (cdr (assoc 2 (entget e))))
    (if
      (and
	(equal (cdr (assoc 5 (entget e))) ref)
	(equal typ "INSERT")
	(equal (cdr (assoc 66 (entget e))) 1)
      )
      (progn
	 (einzel-attr-aendern bezeichnung wert addition)
	 (setq raus 1)  ; rausspringen !!!
      )
    )
    (setq e (entnext e))
    (if (= RAUS 1)
       (setq e NIL)
    )
  )
)

(defun einzel-attr-aendern (BEZEICHNUNG WERT ADDITION)
  (while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
     (setq typ (cdr (assoc 0 (entget e))))
     (if
	(equal typ "ATTRIB")
	(progn
	   (setq ATTRIBUT-BEZEICHNUNG (cdr (assoc 2 (entget e))))
	   (setq ATTRIBUT-WERT        (cdr (assoc 1 (entget e)))) 
	   (if (= ADDITION 0)   ; Attributwert GANZ ersetzen
	      (progn
		 (if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG) 
		      (entmod (subst (cons 1 WERT)
			    (assoc 1 (entget e)) (entget e)))
		 )
	      )
	   )
	   (if (= ADDITION 1)   ; Attributwert ERGAENZEN
	      (progn
		 (if (equal ATTRIBUT-BEZEICHNUNG BEZEICHNUNG) 
		      (entmod (subst (cons 1 (strcat ATTRIBUT-WERT WERT))
			    (assoc 1 (entget e)) (entget e)))
		 )
	      )
	   )

	)  ; Ende ----progn
     )  
     (setq e (entnext e))
  )
)
;--------------------------------------------------------------------------
(vmon)
(setq *lw* "c:")
(setq
      v-lay (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
      v-col (list "7" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")
      v-ltyp (list "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" "continuous" )
)
;----------------------------------------------------------------------------
(if (= g_l 0)(setq g_l 3))
(setvar "cmdecho" 0)
(setq g_si2 (getvar "tdindwg"))
(prompt "\nSST-Menu.. (c) 1998 by SCHÖNENBERGER Systeme GmbH - All rights reserved")
(prompt " ")
;(load "dingen")
;v-lay richtig belegen
(if (/= (setq du 
  (substr (getvar "clayer") 1 (searc "-" (getvar "clayer")))) nil)
(progn
   (setq ct (- (length v-lay) 1))
   (while (>= ct 0) 
     (setq v-lay (subst (strcat du (nth ct v-lay)) (nth ct v-lay) v-lay)
	   ct (- ct 1)))
))
;(load "sstbase")

(princ)