;;; *********************************************************************
;;; TXT_SET.LSP (c) 1998 by Marc Scherer
;;; Kontakt: marc.scherer@zvo.com
;;;
;;; Lauffähig unter AutoCAD 2000/2000i
;;; 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.

;;; Kontakt TAL-LSP:
;;; Holger Brischke
;;; Metro Real Estate Management GmbH
;;; DV-CAD
;;; 66123 Saarbrücken
;;; Bertha-v-Suttner-Str. 5
;;; [0049]-(0)681/8104-2584
;;; brischkh@mre.de
;;;
;;;
;;; Kontakt TXT_SET.LSP:
;;; Marc Scherer
;;; marc.scherer@zvo.com
;;;
;;;
;;; Version 2 vom 18.10.20001
;;; *********************************************************************

;;; *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm *** Main-Pgm ***
;;; PGM erstellt DTEXT
(defun c:txt_set (hoehe / TMP-ORI pkt 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\"REAL\" für Texthöhe, oder \"ENTER\" für <"
(rtos XT-H 2 2)
">: "
) ;_ end strcat
) ;_ end setq
(setq ASK-TXT
"\nZeichne Text auf AKTUELLEM Layer...\n\"REAL\" für Texthöhe: "
) ;_ 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 "Sorry, Fehleingabe. 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 "\nSorry, Objekt 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 (/ TMP-ORI PKT)
(setq TMP-ORI (FROM-OBJ))
(if (= TMP-ORI NIL)
(progn
(initget 41)
(setq PKT (trans (getpoint "\nErster Punkt für Richtung...") 1 0))
(command "_.ucs" "_w")
(setq TMP-ORI
(getorient
PKT
"\nRichtung für Texteinfügung bestimmen..."
) ;_ 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)
(GO-APPLY TMP-ORI)
(princ)
)

;;; *** 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)
(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 "\nSorry KEIN Objekt gewählt !")
)
(t
(setq OBJDATA (entget (setq OBJNAME (car OBJ)))
OBJTYPE (cdr (assoc 0 OBJDATA))
) ;_ end of setq
(cond
((or (eq OBJTYPE "MTEXT")(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
"\nSorry, kein 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"
KEY-WORDS "Zeigen Li->re Un->ob Re->li Ob->un"
) ;_ end of setq
(while (= OBJ NIL)
(initget KEY-WORDS)
(setq OBJ
(nentsel
"\nQuellobjekt \(Polylinie/Linie/Text\) für Textwinkel wählen [Zeigen/Li->re/Un->ob/Re->li/Ob->un]: "
) ;_ end of nentsel
) ;_ end of setq
(cond
((= OBJ NIL)
(princ
"\nSorry, kein Objekt gewählt.\nVersuchs noch mal..."
) ;_ end of princ
)
((eq OBJ KEY) (setq OBJANGLE NIL))
((eq OBJ "Li->re") (setq OBJANGLE 0.0))
((eq OBJ "Un->ob") (setq OBJANGLE (/ (* 2 pi) 4)))
((eq OBJ "Re->li") (setq OBJANGLE (/ (* 2 pi) 2)))
((eq OBJ "Ob->un") (setq OBJANGLE (/ (* 3 (* 2 pi)) 4)))
((= 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)))))
(eq "TEXT" (cdr (assoc 0 (entget (car OBJ)))))
(eq "MTEXT" (cdr (assoc 0 (entget (car OBJ)))))
) ;_ end of or
) ;_ end of =
(setq OBJ NIL)
(princ
"\nSorry, keine gültige Polylinie, Linie oder Text gewählt.\nVersuchs noch mal..."
) ;_ end of princ
)
) ;_ end of cond
) ;_ end of while
(cond
((or (= (type OBJANGLE) 'REAL) (eq OBJ KEY))
(setq OBJANGLE OBJANGLE)
)
(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))
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "MTEXT")
(setq OBJANGLE (cdr (assoc 50 OBJDATA))
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "LINE")
(setq OBJANGLE (angle (cdr (assoc 10 OBJDATA))
(cdr (assoc 11 OBJDATA))
) ;_ end of angle
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "VERTEX")
(if (= (member "geomcal.arx" (arx)) NIL)
(arxload "geomcal.arx")
) ;_ end of if
;_ 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
(setq OBJANGLE (WINKEL-KORREKTUR OBJANGLE))
)
((eq OBJTYPE "LWPOLYLINE")
(if (= (member "geomcal.arx" (arx)) NIL)
(arxload "geomcal.arx")
) ;_ end of if
(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 if
(setq OBJANGLE (WINKEL-KORREKTUR OBJANGLE))
)
) ;_ end of cond
) ;_ end of t
) ;_ end of cond
(if OBJANGLE
(setq OBJANGLE OBJANGLE)
(setq OBJANGLE NIL)
) ;_ end of if
) ;_ end of defun


(defun FROM-OBJ2 (/ 1ST-KORD 2ND-KORD OBJ OBJANGLE
OBJDATA OBJNAME OBJTYPE ONAME ONAME-NXT
KEY ELIST LKLKPT PTLISTE PTLISTE2
X
)
(setq OBJ NIL) ;_ end of setq
(while (= OBJ NIL)
(setq OBJ
(nentsel
"\nQuellobjekt \(Polylinie/Linie/Text\) für BKS-Ausrichtung wählen: "
) ;_ end of nentsel
) ;_ end of setq
(cond
((= OBJ NIL)
(princ
"\nSorry, kein Objekt gewählt.\nVersuchs noch mal..."
) ;_ end of princ
)
((= 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)))))
(eq "TEXT" (cdr (assoc 0 (entget (car OBJ)))))
(eq "MTEXT" (cdr (assoc 0 (entget (car OBJ)))))
) ;_ end of or
) ;_ end of =
(setq OBJ NIL)
(princ
"\nSorry, keine gültige Polylinie, Linie oder Text gewählt.\nVersuchs noch mal..."
) ;_ end of princ
)
) ;_ end of cond
) ;_ end of while
(if obj
(progn
(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))
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "MTEXT")
(setq OBJANGLE (cdr (assoc 50 OBJDATA))
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "LINE")
(setq OBJANGLE (angle (cdr (assoc 10 OBJDATA))
(cdr (assoc 11 OBJDATA))
) ;_ end of angle
OBJANGLE (WINKEL-KORREKTUR OBJANGLE)
) ;_ end of setq
)
((eq OBJTYPE "VERTEX")
(if (= (member "geomcal.arx" (arx)) NIL)
(arxload "geomcal.arx")
) ;_ end of if
;_ 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
(setq OBJANGLE (WINKEL-KORREKTUR OBJANGLE))
)
((eq OBJTYPE "LWPOLYLINE")
(if (= (member "geomcal.arx" (arx)) NIL)
(arxload "geomcal.arx")
) ;_ end of if
(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 if
(setq OBJANGLE (WINKEL-KORREKTUR OBJANGLE))
)
) ;_ end of cond
) ;_ end of progn
) ;_ end of if
(if OBJANGLE
(setq OBJANGLE OBJANGLE)
(setq OBJANGLE NIL)
) ;_ end of if
) ;_ end of defun

(defun Degrees->Radians (numberOfDegrees)
(* pi (/ numberOfDegrees 180.0))
)

(defun Radians->Degrees (numberOfRadians)
(* 180.0 (/ numberOfRadians pi))
)


;;; *** 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 ***
;;; Unterprogramm zur Winkelkorrektur.
;;; "Normalisiert" einen Winkel so, dass er nicht "auf dem Kopf" steht!
(defun winkel-korrektur (Eingangswinkel /)
(if (and (<= Eingangswinkel (* (/ 3.0 4.0) (* 2 pi)))
(> Eingangswinkel (* (/ 1.0 4.0) (* 2 pi)))
) ;_ end of or
(setq Eingangswinkel (+ Eingangswinkel pi))
)
Eingangswinkel ;_ Rückgabe des Winkels an rufende Funktion
)

;;; *** 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)
(if (not (vl-bb-ref 'GET-TW-FLAG))
(princ
"\nWählen Sie das Textobjekt an, von dem Sie den Textwert übernehmen wollen: "
) ;_ end princ
;;; (princ
;;; "\nTextobjekt anklicken dessen Textwert ausgelesen werden soll: "
;;; ) ;_ end of princ
) ;_ end of if
(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 GET-TW-OBJSEL ent ;_ GLOBALE Variable für weitere externe Verwendung
txted (cdr (assoc 1 entdat))
ent nil
) ;_ end setq
) ;_ end progn
(progn
(setq ent T
GET-TW-OBJSEL
nil
) ;_ end of setq
(princ "\nSorry, Objekt war KEIN Text.")
) ;_ end progn
) ;_ end if
) ;_ end progn
(progn
(princ "\nNichts gewählt...")
(setq ent nil
GET-TW-OBJSEL
nil
) ;_ end of setq
) ;_ 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


(defun c:melt-txt (/ ENT ENTBEM ENTDAT GTW SOURCETXT TXTED-ALT TXTED-NEU)
(vl-bb-set 'GET-TW-FLAG T) ;_ Steuert das Verhalten vom get-tw Dialog...
(princ "\nDtext-Objekt wählen, an das Text angehängt werden soll: ")
(setq gtw (get-tw))
(if (= gtw nil)
(princ "\nKein Basis-Text-Objekt gewählt, oder ungültig !")
(progn
(setq sourcetxt get-tw-objsel ;_ Hier ist das Basisentitie drin!
ent T
) ;_ end of setq
(while (/= ent nil)
(princ
"\nTextwerte wählen, die der Ursprungszeile hinzugefügt werden sollen..."
) ;_ end princ
(setq ent (get-tw)) ;_ Textwertermittlung
(if ent
(progn
(setq ent (strcat " " ent) ;_ Leerzeichen vorhängen
entdat (entget sourcetxt) ;_ Daten vom ersten Text erfragen
entbem (cdr (assoc 0 entdat))
) ;_ end setq
(if (= entbem "TEXT")
(progn
(setq txted-alt (assoc 1 entdat)
txted-neu (cons 1 (strcat (cdr txted-alt) ent))
entdat (subst txted-neu txted-alt entdat)
) ;_ end setq
(entmod entdat)
(setq ent T)
) ;_ end progn
(progn
(setq ent T)
(princ "\nSorry, Objekt 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
(vl-bb-set 'GET-TW-FLAG nil)
(princ "\nOK, Funktionsende !")
(princ)
) ;_ end of defun

(defun C:TCLONE ()
(if (setq SOURCE-OBJ
(->VLA-OBJECT
(car (entsel "\nQuell-Text-Objekt wählen: "))
)
)
(if (setq OBJ-PROP (DT:DUMP-OBJECT SOURCE-OBJ))
(if (setq OBJ-PROP (vl-remove-if-not
'(lambda (X) (= (car X) 'TEXTSTRING))
(car OBJ-PROP)
)
)
(if (setq TARGET-OBJ
(->VLA-OBJECT
(car (entsel "\nZiel-Text-Objekt wählen: "))
)
)
(setq retval (DT:CLONE-PROPERTIES TARGET-OBJ OBJ-PROP))
)
)
)
)
retval
)

(princ)