;;;*****************************************************************************
;;;TRANSFER Version 1.0	18.3.1993					 
;;;
;;; Nach der Initialisierung, die versch. globale Einstellungen konfiguriert und
;;; die nötigen Layer anlegt, werden aus einer Datei, die einzelne Punkte und
;;; die zugehörigen Punktnummern enthält diese gelesen und in die aktuelle Auto-
;;; CAD Zeichnung eingesetzt; gleichzeitig werden auf korresp. Layern Kontroll
;;; blöcke mit den entspr. Punktbezeichnungen eingesetzt.
;;; Die Datei muss dabei folgendes Aussehen haben:
;;; X-Koord1,Y-Koord1,Bez. auf Layer1,Bez. auf Layer2, .... 
;;; X-Koord2,Y-Koord2,Bez. auf Layer1,Bez. auf Layer2, .... 
;;; .....
;;; Frei konfigurierbar sind dabei
;;; Trennzeichen			'trenn'
;;; Anzahl der Layer			'layer_anz'
;;; Bez. für nicht belegten Layer	'blank'
;;; Änderungen	wer		wann		was
;;; HH&HS		18.3.93	Version 1.0 & very hard testing	
;;;*****************************************************************************
(princ "\nTRANSF1 v1.0")
(princ "\nLaden .  ")
(defun C:INIT (/ i lnam llist)
					;****************** KONFIGURATION *******************************************
					;legt die Einstellungen f. die Übertragung fest; feel free to edit (if u know)

  (setq offset '(36 157.69))		;Nullpunkt der Fläche
					;                                       
					;LAYER	der Namen setzt sich zusammen aus Prefix,lfd. Nummer und Postfix
					;			z.B: Nummer1 ... Nummer2, Nummer1Z ... Nummer2Z,
  (setq layer_anz 4)			;Anzahl der Layer
  (setq layerpref "Masch_")		;Prefix des Layernamens
  (setq layerpost "z")			;Postfix   -" -
  (setq blockname "Nummer von Oben")	;Block zur Kontrolle auf den -z Layer
					;ACHTUNG: muss im aktuellen Verzeichnis exist.
  (setq trenn ",")			;Trennzeichen zwischen records
  (setq blank 0)			;kein Eintrag
  (setq startdir "C:\Textfiles")	;Vorgabe beim Koordfile wählen
  (setq koordext "TXT")			;Extension f.d. Koordinatenfiles
  (setq prlist '(| \ - /))		;funny little list
;;;*****************************************************************************
  (setq ocmdecho (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setq i 1)
  (while (<= i layer_anz)
    (if	(= i 1)
      (setq llist (setq lnam (strcat layerpref (itoa i))))
      (setq llist
	     (strcat llist "," (setq lnam (strcat layerpref (itoa i))))
      )
    )
    (setq llist (strcat llist "," (strcat lnam layerpost)))
    (setq i (1+ i))
  )
  (command "._-layer" "_make" llist "")
  (setq i 1)
  (while (<= i layer_anz)
    (command "._-layer"
	     "_color"
	     i
	     (strcat layerpref (itoa i) "*")
	     ""
    )
    (setq i (1+ i))
  )
;;;'fertig
)
(princ ".")
(defun C:TRANSFER ()
  (setq oosmode (getvar "OSMODE"))
  (setq oucsicon (getvar "UCSICON"))
  (setq oclayer (getvar "CLAYER"))
  (setvar "OSMODE" 0)
  (setvar "UCSICON" 2)
  (setq asck (ascii "."))
  (setq asct (ascii trenn))
  (setq error nil)
  (setq eof nil)
  (setq j 0)
  (setq mstatus (+ 2 layer_anz))
  (command "._ucs" "_world")
  (command "._ucs" "_o" offset)
  (command "._ucs" "x" 180)
  (if layer_anz
    (progn
      (setq
	datei (getfiled "Koordinatendatei wählen" startdir koordext 4)
      )
      (if datei
	(if (setq f (open datei "r"))
	  (progn
	    (setq status 0)
	    (setq n 0)
	    (setq error nil)
	    (princ "\nÜbertragung läuft:  ")
	    (while (and (not error) (not eof))
	      (if (= status mstatus)
		(setq status 1)
		(setq status (1+ status))
	      )
	      (setq pkoord nil)
	      (cond
		((= status 1)
		 (if (setq pkoord (lies-zahl nil))
		   (setq plist (list pkoord))
		   (setq error T)
		 )
		 (if eol
		   (setq error T)
		   (progn
		     (if (and eof (/= str ""))
		       (setq error T)
		     )
		   )
		 )
		)
		((= status 2)
		 (if (and (setq pkoord (lies-zahl nil))
			  (not eol)
			  (not eof)
		     )
		   (setq plist (reverse (cons pkoord plist)))
		   (setq error T)
		 )
		)
		((<= status mstatus)
		 (if (= status mstatus)
		   (progn
		     (setq n (1+ n))
		     (if
		       (not
			 (and (setq attrib (lies-zahl T)) (or eof eol))
		       )
			(setq error T)
			(if (and eof (= "" str))
			  (setq error T)
			)
		     )
		   )
		   (if (not (and (setq attrib (lies-zahl T))
				 (not eol)
				 (not eof)
			    )
		       )
		     (setq error T)
		   )
		 )
		 (if (/= attrib 0)
		   (progn
		     (setvar
		       "CLAYER"
		       (setq
			 lnam (strcat layerpref (itoa (- status 2)))
		       )
		     )
		     (command "._point" plist)
		     (setvar "CLAYER" (strcat lnam layerpost))
		     (command "._insert" blockname plist "1" "1" "0"
			      attrib)
		     (if (= (rem n 5) 0)
		       (progn
;;;(princ "\010")
			 (princ (nth j prlist))
			 (if (= j (1- (length prlist)))
			   (setq j 0)
			   (setq j (1+ j))
			 )
		       )
		     )
		   )
		 )
		)
	      )
	    )
	    (if	error
	      (progn
		(princ "\nFehler beim Lesen der Datei '")
		(princ datei)
		(princ "' in der Zeile ")
		(princ n)
		(princ ".\n")
	      )
	    )
	    (close f)
	  )
	  (progn
	    (princ "\nDie Koordinatendatei '")
	    (princ (strcase datei))
	    (princ "' kann nicht geöffnet werden.\n")
	    (setq error T)
	  )
	)
	(progn
	  (princ "\nKeine Datei ausgewählt.\n")
	  (setq error T)
	)
      )
      (if error
	(alert "ABBRUCH: Es wurden keine Daten übertragen!")
	(progn
	  (princ "Anzahl der übertragenen Punkte: ")
	  (princ n)
	  (princ "\n")
	)
      )
      (command "._ucs" "_wold")
      (setvar "CMDECHO" ocmdecho)
      (setvar "UCSICON" oucsicon)
      (setvar "OSMODE" oosmode)
      (setvar "CLAYER" oclayer)
;;;'fertig
    )
    (alert "ABBRUCH: Transfer ist noch nicht initialisiert!")
  )
)
(princ ".")
(defun lies-zahl (ganz)
  (setq komma ganz)
  (setq done nil)
  (setq error nil)
  (setq eol nil)
  (setq eof nil)
  (setq str "")
  (while (not done)
    (setq c (read-char f))
    (cond
      ((and (<= (ascii "1") c) (>= (ascii "9") c))
       (setq str (strcat str (chr c)))
      )
      ((= c (ascii "0"))
       (if (and (= str "") komma)
	 (setq str (chr c))
       )
       (setq str (strcat str (chr c)))
      )
      ((= c asck)
       (if komma
	 (progn
	   (setq error T)
	   (setq done T)
	 )
	 (progn
	   (setq str (strcat str "."))
	   (setq komma T)
	 )
       )
      )
      ((= c asct)
       (if (= "" str)
	 (setq error T)
       )
       (setq done T)
      )
      ((= c 10)
       (if (= "" str)
	 (setq error T)
       )
       (setq eol T)
       (setq done T)
      )
      ((not c)
       (setq eof T)
       (setq done T)
      )
      (T
       (setq error T)
       (setq done T)
      )
    )
  )
  (if (not error)
    (if	ganz
      (atoi str)
      (atof str)
    )
  )
)
(princ ".")
(princ
  "    Initialisieren mit 'INIT', Starten mit 'TRANSFER'   "
)
;;;'fertig