;;; *********************************************************************
;;;
;;; Lauffähig unter AutoCAD 2000/2000i/2002
;;; Programmaufruf mit:
;;;	"xt" oder "(C:TXT_SET [Real])" für Texteintragung
;;;	"txt" für Textwertübertragungen
;;;	"align-txt" für Textausrichtungsübertragungen

;;; Textausrichtungen werden immer so vorgenommen, das sie nie auf dem
;;; Kopf stehen, sondern (bezogen auf das WKS) von Vorn
;;; oder von Rechts lesbar sind. Ausnahme ist das "Zeigen" der Richtung.

;;; Tool zum Erstellen von DTEXT-Objekten in Topographischen Lageplänen
;;;
;;; LWPOLYLINIEN-Part des PGM teilweise der
;;; "TAL.LSP" von Holger Brischke entnommen.
;;; *********************************************************************

;;; *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm ***
;;; PGM erstellt DTEXT
(defun c:txt_set (hoehe / TMP-ORI pkt ori eingabe dcl_id newtxt NEWTXTLIST STYLE-LIST)
  (setq pkt (getpoint "\nStartpunkt für Texteinfügung klicken: "))
  (while pkt
    (setq TMP-ORI (FROM-OBJ))
    (if	(= TMP-ORI NIL)
      (progn
	(setq PKT (trans PKT 1 0))
	(command "_.ucs" "_w")
	(setq TMP-ORI
	       (getorient
		 PKT
		 "\nRichtung für Texteinfügung bestimmen, oder Space/Enter für vorherige: "
	       ) ;_ end getorient
	) ;_ end setq
	(command "_.ucs" "_p")
	(setq PKT (trans PKT 0 1))
      ) ;_ end of progn
    ) ;_ end of if
    (if	(= ori nil)
      (setq ori 0.0)
    ) ;_ end if
    (if	(= tmp-ori nil)
      (setq tmp-ori ori)
    ) ;_ end if
    (setq ori tmp-ori)
    (if	ms_txt
      (progn
	(setq eingabe
	       (getstring
		 T
		 (strcat
		   "\nAktueller Text: "
		   "\t\""
		   ms_txt
		   "\""
		   "\nNEUEN Text eingeben; \"ü+Enter\" zum Übernehmen oder Rechtsklick/Enter für aktuellen: "
		 ) ;_ end strcat
	       ) ;_ end getstring
	) ;_ end setq
	(if eingabe
	  (setq xeingabe (nul-del eingabe))
	  )
	(cond
	  ((or (= eingabe "") (= xeingabe ""))
	   (if (= ms_txt "")
	     (progn
	       (setq ms_txt nil)
	       (alert "Unzulässig !\nTextwert war leer.\nProgrammende !"
	       ) ;_ end alert
	     ) ;_ end progn
	     (setq ms_txt ms_txt)
	   ) ;_ end if
	  )
	  ((and (= (type eingabe) 'STR) (/= eingabe ""))
	   (if (or (= (nul-del eingabe) "ü") (= (nul-del eingabe) "Ü"))
	     (progn
	       (setq ms_txt (get-tw))
	       (if (= ms_txt nil)
		 (progn
		   (princ "\n...und noch einmal...")
		   (c:txt_set hoehe)
		 ) ;_ end progn
		 (setq ms_txt ms_txt)
	       ) ;_ end if
	     ) ;_ end progn
	     (setq ms_txt eingabe)
	   ) ;_ end if
	  )
	) ;_ end cond
      ) ;_ end progn
      (progn
	(setq eingabe
	       (getstring
		 T
		 "\nEinzufügenden Text eingeben, oder \"ü+Enter\" zum Übernehmen: "
	       ) ;_ end getstring
	) ;_ end setq
	(if eingabe
	  (setq xeingabe (nul-del eingabe))
	  )
	(cond
	  ((or (= eingabe "") (= xeingabe ""))
	   (setq ms_txt nil)
	   (alert "Unzulässig !\nTextwert war leer.\nProgrammende !")
	  )
	  ((and (= (type eingabe) 'STR) (/= eingabe ""))
	   (if (or (= (nul-del eingabe) "ü") (= (nul-del eingabe) "Ü"))
	     (progn
	       (setq ms_txt (get-tw))
	       (if (= ms_txt nil)
		 (c:txt_set hoehe)
		 (setq ms_txt ms_txt)
	       ) ;_ end if
	     ) ;_ end progn
	     (setq ms_txt eingabe)
	   ) ;_ end if
	  )
	) ;_ end cond
      ) ;_ end progn
    ) ;_ end if
    (if	(/= ms_txt nil)
      (progn
	(if (= (tblsearch "STYLE" "SIMPLEX") NIL)
	  (progn
	    (setq STYLE-LIST
		   (list '(0 . "STYLE")	'(100 . "AcDbSymbolTableRecord")
			 '(100 . "AcDbTextStyleTableRecord") '(2 . "SIMPLEX")
			 '(70 . 0) '(40 . 0.0) '(41 . 1.0) '(50 . 0.0)
			 '(71 . 0) '(42 . 2.5) '(3 . "simplex.shx") '(4 . "")) ;_ end of list
	    ) ;_ end of setq
	    (entmake STYLE-LIST)
	  ) ;_ end of progn
	) ;_ end of if
	(setq PKT	 (trans PKT 1 0)
	      NEWTXTLIST
			 (list '(0 . "TEXT")
			       (cons 10 PKT)
			       (cons 40 HOEHE)
			       (cons 1 MS_TXT)
			       (cons 7 "SIMPLEX")
			       (cons 50 ORI)
			 ) ;_ end of list
	) ;_ end of setq
	(entmake NEWTXTLIST)	      
	(setq pkt
	       (getpoint
		 "\nStartpunkt für weitere Texteinfügung klicken, oder Space/Enter für Ende: "
	       ) ;_ end getpoint
	) ;_ end setq
      ) ;_ end progn
      (setq pkt nil)
    ) ;_ end if
  ) ;_ end while
  (princ)
) ;_ end defun

;;; *** Main-Variante *** Main-Variante *** Main-Variante *** Main-Variante ***
;;; Pgm zum Aufruf der Hauptfunktion TXT_SET wenn TXT_SET nach einer
;;; Texthöhe fragen soll.
(defun C:XT (/ ASK-TXT XT-HX)
  (if XT-H
    (setq ASK-TXT
	   (strcat
	     "\nZeichne Text auf AKTUELLEM Layer...\n\"Texthöhe eingeben, oder \"ENTER\" für <"
	     (rtos XT-H 2 2)
	     ">: "
	   ) ;_ end strcat
    ) ;_ end setq
    (setq ASK-TXT
	   "\nZeichne Text auf AKTUELLEM Layer...\n\"Texthöhe eingeben: "
    ) ;_ end setq
  ) ;_ end if
  (initget 6) ;_ Keine null oder negativ
  (setq	XT-HX (getreal ASK-TXT) ;_ end getreal
  ) ;_ end setq
  (cond	((and (= XT-HX NIL) (/= XT-H NIL)) (C:TXT_SET XT-H))
	((= (type XT-HX) 'REAL) (setq XT-H XT-HX) (C:TXT_SET XT-H))
	(t (alert "Eingabe nicht korrekt. Programmende!"))
  ) ;_ end cond
  (princ)
) ;_ end defun

;;; *** Main-Variante *** Main-Variante *** Main-Variante *** Main-Variante ***
;;; Aufruf mit globaler Variable "XXT-H" aus anderem LISP-PGM
(defun C:XXT (/)
  (if XXT-H
    (C:TXT_SET XXT-H)
  ) ;_ end of if
) ;_ end of defun

;;; *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm ***
;;; Pgm überträgt Quelltextwert auf Dtext-Objekte
(defun c:txt (/ ENT ENTBEM ENTDAT GTW TXTED-ALT TXTED-NEU)
  (setq gtw (get-tw))
  (if (= gtw nil)
    (princ "\nKein Quellobjekt gewählt, oder ungültig !")
    (progn
      (princ
	"\nText\(e\) zur Textwertübertragung wählen..."
      ) ;_ end princ
      (setq ent T)
      (while (/= ent nil)
	(setq ent
	       (car
		 (entsel "\n...übertragen auf...\(Rechtsklick=Ende\)"
		 ) ;_ end entsel
	       ) ;_ end car
	) ;_ end setq
	(if ent
	  (progn
	    (setq entdat (entget ent)
		  entbem (cdr (assoc 0 entdat))
	    ) ;_ end setq
	    (if	(= entbem "TEXT")
	      (progn
		(setq txted-alt	(assoc 1 entdat)
		      txted-neu	(cons 1 gtw)
		      entdat	(subst txted-neu txted-alt entdat)
		) ;_ end setq
		(entmod entdat)
		(setq ent T)
	      ) ;_ end progn
	      (progn
		(setq ent T)
		(princ "\nObjekt war KEIN Text.")
	      ) ;_ end progn
	    ) ;_ end if
	  ) ;_ end progn
	  (progn
	    (princ "\nNichts gewählt...")
	    (setq ent nil)
	  ) ;_ end progn
	) ;_ end if
      ) ;_ end while
    ) ;_ end progn
  ) ;_ end if
  (princ "\nOK, Programmende !")
  (princ)
) ;_ end defun

;;; *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm ***
;;; Spezialisiertes Pgm zum erstellen von Detailmarkern
(defun c:detmark ( / pt tx os-mod)
  (setq	pt (getpoint "\nPunkt für Detail-Markierung klicken: ")
	tx (getstring
	     "\nText für Detail-Markierung eingeben z.B. \"G99\":"
	   )
  )
  (if (and pt (and (not (eq tx nil))(not (eq (vl-string-trim " " tx) ""))))
    (progn
      (setq os-mod (getvar "osmode"))
      (setvar "osmode" 0)
      (setvar "cecolor" "2")
      (setvar "lastpoint" pt)
      (command "_.circle" pt 2.8)
      (command "_.text" "_j" "_c" "@0,-0.8355" 1.75 "100g" tx "")
      (setvar "cecolor" "BYLAYER")
      (setvar "osmode" os-mod)
      (princ "\nOk, erledigt...")
    )
    (princ "\nKeinen Punkt oder Text eingegeben. Programmende")
  )
  (princ)
)

;;; *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm ***
(defun C:ALIGN-TXT (/ OBJDATA OBJNAME OBJTYPE OBJ)
  (setq
    OBJ	(nentsel
	  "\nQuellobjekt \(Polylinie/Linie/Text\) für Winkel wählen: "
	) ;_ end of nentsel
  ) ;_ end of setq
  (cond
    ((= OBJ NIL)
     (princ "\nKEIN Objekt gewählt. Programmende!")
    )
    (t
     (setq OBJDATA (entget (setq OBJNAME (car OBJ)))
	   OBJTYPE (cdr (assoc 0 OBJDATA))
     ) ;_ end of setq
     (cond
       ((eq OBJTYPE "TEXT") (GO-TXT OBJDATA))
       ((eq OBJTYPE "LINE") (GO-LINE OBJDATA))
       ((eq OBJTYPE "VERTEX") (GO-PLINE OBJDATA))
       (t
	(princ
	  "\nkeine gültige Polylinie, Linie oder Text gewählt. Programmende!"
	) ;_ end of princ
       )
     ) ;_ end of cond
    ) ;_ end of T
  ) ;_ end of cond
  (princ)
) ;_ end of defun


;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
(defun GO-TXT (DATA / OBJANGLE)
  (princ "\nText gewählt...")
  (setq OBJANGLE (cdr (assoc 50 DATA)))
  (GO-APPLY OBJANGLE)
) ;_ end of defun

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
(defun GO-LINE (DATA / OBJANGLE)
  (princ "\nLinie gewählt...")
  (setq OBJANGLE (angle (cdr (assoc 10 DATA)) (cdr (assoc 11 DATA))))
  (GO-APPLY OBJANGLE)
) ;_ end of defun

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
(defun GO-PLINE	(DATA / 1ST-KORD 2ND-KORD OBJANGLE ONAME ONAME-NXT)
  (princ "\nPolylinie gewählt...")
  (setq	ONAME	  (cdr (assoc -1 DATA))
	1ST-KORD  (cdr (assoc 10 DATA))
	ONAME-NXT (entget (entnext ONAME))
	2ND-KORD  (cdr (assoc 10 ONAME-NXT))
	OBJANGLE  (angle 1ST-KORD 2ND-KORD)
  ) ;_ end of setq
  (GO-APPLY OBJANGLE)
) ;_ end of defun

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
(defun GO-APPLY	(OBJANGLE / NEW-ANGLE NEW-LST OBJ OBJDATA OBJNAME
		 OBJTYPE OLD-ANGLE)
  (if (and (<= OBJANGLE (* (/ 3.0 4.0) (* 2 pi)))
	   (> OBJANGLE (* (/ 1.0 4.0) (* 2 pi)))
      ) ;_ end of or
    (setq OBJANGLE (+ OBJANGLE pi))
  ) ;_ end of if
  (setq NEW-ANGLE (cons 50 OBJANGLE))
  (while (/= (setq
	       OBJ
		(entsel
		  "\nZielobjekt \(Text\) für Winkel wählen \(Rechtsklick=Ende\): "
		) ;_ end of nentsel
	     ) ;_ end of setq
	     NIL
	 ) ;_ end of /=
    (cond
      ((= OBJ NIL)
       (princ "\nKEIN Objekt gewählt !")
      )
      (t
       (setq OBJDATA (entget (setq OBJNAME (car OBJ)))
	     OBJTYPE (cdr (assoc 0 OBJDATA))
       ) ;_ end of setq
       (cond
	 ((eq OBJTYPE "TEXT")
	  (setq	OLD-ANGLE (assoc 50 OBJDATA)
		NEW-LST	  (subst NEW-ANGLE OLD-ANGLE OBJDATA)
	  ) ;_ end of setq
	  (entmod NEW-LST)
	  (entupd OBJNAME)
	 )
	 (t
	  (princ
	    "\nkein gültiges Zielobjekt \(Text\) gewählt !"
	  ) ;_ end of princ
	 )
       ) ;_ end of cond
      ) ;_ end of T
    ) ;_ end of cond
  ) ;_ end of while
  (princ)
) ;_ end of defun

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
;;; Ermittelt den Winkel für Textobjekt aus Linie,Polylinie,Text und LWPOLY
(defun FROM-OBJ	(/	   1ST-KORD  2ND-KORD  OBJ	 OBJANGLE
		 OBJDATA   OBJNAME   OBJTYPE   ONAME	 ONAME-NXT
		 KEY	   ELIST     LKLKPT    PTLISTE	 PTLISTE2
		 X
		)
  (setq	OBJ NIL
	KEY "Zeigen"
  ) ;_ end of setq
  (while (= OBJ NIL)
    (initget KEY)
    (setq OBJ
	   (nentsel
	     "\nQuellobjekt \(Polylinie/Linie/Text\) für Textwinkel wählen [Zeigen]: "
	   ) ;_ end of nentsel
    ) ;_ end of setq
    (cond
      ((= OBJ NIL)
       (princ
	 "\nkein Objekt gewählt.\nVersuchs noch mal..."
       ) ;_ end of princ
      )
      ((eq OBJ KEY) (setq OBJ OBJ))
      ((= NIL
	  (or
	    (eq "LINE" (cdr (assoc 0 (entget (car OBJ)))))
	    (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car OBJ)))))
	    (eq "VERTEX" (cdr (assoc 0 (entget (car OBJ)))))
	  ) ;_ end of or
       ) ;_ end of =
       (princ
	 "\nkeine gültige Polylinie, Linie oder Text gewählt.\nVersuchs noch mal..."
       ) ;_ end of princ
      )
    ) ;_ end of cond
  ) ;_ end of while  
  (cond
    ((eq OBJ KEY) (setq OBJANGLE NIL))
    (t
     (setq OBJDATA (entget (setq OBJNAME (car OBJ)))
	   OBJTYPE (cdr (assoc 0 OBJDATA))
	   LKLKPT  (trans (cadr OBJ) 1 0)
     ) ;_ end of setq
     (cond
       ((eq OBJTYPE "TEXT")
	(setq OBJANGLE (cdr (assoc 50 OBJDATA))) ;_ end of setq
	(if (and (<= OBJANGLE (* (/ 3.0 4.0) (* 2 pi)))
		 (> OBJANGLE (* (/ 1.0 4.0) (* 2 pi)))
	    ) ;_ end of or
	  (setq OBJANGLE (+ OBJANGLE pi))
	) ;_ end of if
       )
       ((eq OBJTYPE "LINE")
	(setq OBJANGLE (angle (cdr (assoc 10 OBJDATA))
			      (cdr (assoc 11 OBJDATA))
		       ) ;_ end of angle
	) ;_ end of setq
	(if (and (<= OBJANGLE (* (/ 3.0 4.0) (* 2 pi)))
		 (> OBJANGLE (* (/ 1.0 4.0) (* 2 pi)))
	    ) ;_ end of or
	  (setq OBJANGLE (+ OBJANGLE pi))
	) ;_ end of if
       )
       ((eq OBJTYPE "VERTEX")
	 (arxload "geomcal.arx")
	;_ erstellen einer Punktliste der Polyline
	 (setq EL    (entget (setq en (cdr (assoc 330 OBJDATA))))
	       Z     0
	       ptliste2 '()
	 ) ;_ end setq
	 (while	(and (setq EN (entnext EN))
		     (= (cdr (assoc 0 (setq EL (entget EN)))) "VERTEX")
		) ;_ end and
	   (setq P (cdr (assoc 10 EL))
		 P (list (car P) (cadr P))
	   ) ;_ end setq
	   (if (= (member P ptliste2) NIL)
	     (setq ptliste2 (append (list P) ptliste2))
	   ) ;_ end if
	 ) ;_ end while
	(setq PTLISTE  (SEARCHPLSEGMENT PTLISTE2 LKLKPT))
	(if (= ptliste nil)
	  (setq OBJANGLE (angle (car ptliste2)(last ptliste2)))
	  (setq OBJANGLE (angle (car PTLISTE) (cadr PTLISTE)))
	) ;_ end of setq
	(if (and (<= OBJANGLE (* (/ 3.0 4.0) (* 2 pi)))
		 (> OBJANGLE (* (/ 1.0 4.0) (* 2 pi)))
	    ) ;_ end of or
	  (setq OBJANGLE (+ OBJANGLE pi))
	) ;_ end of if
       )
       ((eq OBJTYPE "LWPOLYLINE")
	(arxload "geomcal.arx")
	(setq ELIST    (entget OBJNAME)
	      PTLISTE2 (apply
			 'append
			 (mapcar
			   '(lambda (X)
			      (if (= 10 (car X))
				(list (cdr X))
			      ) ;_ end of if
			    ) ;_ end of lambda
			   ELIST
			 ) ;_ end of mapcar
		       ) ;_ end of apply
	) ;_ end of setq
	(setq PTLISTE  (SEARCHPLSEGMENT PTLISTE2 LKLKPT))
	(if (= ptliste nil)
	  (setq OBJANGLE (angle (car ptliste2)(last ptliste2)))
	  (setq OBJANGLE (angle (car PTLISTE) (cadr PTLISTE)))
	) ;_ end of setq
	(if (and (<= OBJANGLE (* (/ 3.0 4.0) (* 2 pi)))
		 (> OBJANGLE (* (/ 1.0 4.0) (* 2 pi)))
	    ) ;_ end of or
	  (setq OBJANGLE (+ OBJANGLE pi))
	) ;_ end of if
       )
     ) ;_ end of cond
    ) ;_ end of t
  ) ;_ end of cond
  (if OBJANGLE
    (setq OBJANGLE OBJANGLE)
    (setq OBJANGLE NIL)
  ) ;_ end of if
) ;_ end of defun

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
;;; Sucht das geklickte Polyliniensegment
(defun searchplsegment (ptli klkpt / za pt1 pt2 aept)
  (setq za 0)
  (repeat (1- (length ptli))
    (setq pt1 (nth za ptli))
    (setq pt2 (nth (1+ za) ptli))
    (setq za (1+ za))
    (if (klksegmentepr pt1 pt2 klkpt)
      (setq aept (list pt1 pt2))
    )
  )
  aept
)

;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
;;; Ermittelt den Vektor eines LWPolylinien-Segmentes
(defun klksegmentepr (ap1 ep1 ap2 / rtg rv1 rv2 rv3)
  (setq rv1 (cal "vec1(ap1,ap2)"));Richtungsvector bestimmen
  (setq rv2 (cal "vec1(ap2,ep1)"))
  (setq rv3 (cal "vec1(ap1,ep1)"))
  (if (= T (and
	     (equal rv1 rv2 0.5)
	     (equal rv1 rv3 0.5)
	     (equal rv2 rv3 0.5)
	   )
      )
    (setq rtg T)
    (setq rtg nil)
  )
  rtg
)


;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
;;; Ermittelt den Textwert eines Dtext-Objektes
(defun get-tw (/ ENT ENTBEM ENTDAT TXTED)
  (princ
    "\nWählen Sie das Textobjekt an, von dem Sie den Textwert übernehmen wollen: "
  ) ;_ end princ
  (setq ent T)
  (while (/= ent nil)
    (setq ent
	   (car
	     (nentsel "\nTextobjekt anklicken, oder \(Rechtsklick=Ende\)"
	     ) ;_ end entsel
	   ) ;_ end car
    ) ;_ end setq
    (if	ent
      (progn
	(setq entdat (entget ent)
	      entbem (cdr (assoc 0 entdat))
	) ;_ end setq
	(if (= entbem "TEXT")
	  (progn
	    (setq txted	(cdr (assoc 1 entdat))
		  ent	nil
	    ) ;_ end setq
	  ) ;_ end progn
	  (progn
	    (setq ent T)
	    (princ "\nObjekt war KEIN Text.")
	  ) ;_ end progn
	) ;_ end if
      ) ;_ end progn
      (progn
	(princ "\nNichts gewählt...")
	(setq ent nil)
      ) ;_ end progn
    ) ;_ end if
  ) ;_ end while
  (if txted
    (setq txted txted)
    (setq txted nil)
  ) ;_ end if
) ;_ end defun


;;; *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm *** Sub-Pgm ***
;;; Löschen ALLER Leerzeichen innerhalb des übergebenen Strings...
;;; Input: "   123 456 789   " -> "123456789"
;;; Input: "123456789" -> "123456789" [logisch ;-) ]
(defun nul-del (t-x-t / INDEX NEW-TXT QUEST S-LEN ZCH BACK)
  (setq quest (vl-string-search " " t-x-t)) ;_ Leerzeichen vorhanden?
  (if (= quest nil)
    (setq t-x-t t-x-t)
    (progn
      (setq t-x-t (vl-string-trim " " t-x-t) ;_ Leerz. am Anfang und Ende entfernen
	    quest (vl-string-search " " t-x-t) ;_ Leerzeichen vorhanden?
      ) ;_ end setq
      (if (= quest nil)
	(setq t-x-t t-x-t)
	(progn
	  (setq	index 1
		new-txt ""
		s-len (strlen t-x-t)
	  ) ;_ end setq
	  (while (<= index s-len)
	    (setq zch (substr t-x-t index 1))
	    (if	(/= zch " ")
	      (setq new-txt (strcat new-txt zch))
	    ) ;_ end if
	    (setq index (1+ index))
	  ) ;_ end while
	  (setq t-x-t new-txt)
	) ;_ end progn
      ) ;_ end if
    ) ;_ end progn
  ) ;_ end if
  (setq back t-x-t)
) ;_ end defun


(princ)