---

tal.txt

Ich habe eine tal lisp
mit der ich Texte einer Linie entlang ausrichten kann
leider aber nur Dtexte
gibt es eine mit der man auch Absatztexte ausrichten kann?
Oder kann ich diese lisp umschreiben? (als Anhang)

Danke schon jetzt fuer eure Hilfe

lg Dimy

------------------
geht nicht.. gibts nicht

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Esetze mal
(= "TEXT" (cdr (assoc 0 (entget(car lin1)))))
durch
(= "DTEXT" (cdr (assoc 0 (entget(car lin1)))))

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Aber Thomas,
seit wann ist denn DText Absatztext?
Hast Du Deine Achillessehne im Kopf?

------------------
Ciao,
Marc

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

guter Tip, aber hat leider nicht funktioniert

schade 

trotzdem danke

lg Dimy

------------------
geht nicht.. gibts nicht

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

meinte
..
durch
(= "MTEXT" (cdr (assoc 0 (entget(car lin1)))))
ersetzen

..sorry,
@Marc so ist das halt im "Stress" 

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Moin,

das klappt nicht; dann kommt die Meldung, daß diesem Objekt kein UCS zugeschrieben werden kann

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi CADmium,
ob das so einfach ist? Hast Du das getestet?

@Dimitra75:
Teste mal meinen Code. Ich habe keine Lust die ganzen Subroutinen zusammenzusuchen, deswegen pack ich mal den ganzen Code hier rein.
Die Funktion die DU brauchst ist C:ALIGN-TXT. Kannst ja die anderen C:* Funktionen auch mal testen, das ein oder andere könnte eventuell ganz nützlich sein, kann auch sein das die ein oder andere Funktion nicht läuft, weil eine Sub aus meiner Bibliothek fehlt... Aber ist halt BTN :-).
An alle Lisp-kundigen, bitte seht mir den Style nach... Es handelt sich um sehr alten gewachsenen Code *grusel* :-)

Code:

---

;;; *********************************************************************
;;; 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.2001
;;; *********************************************************************

;;; *** 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)

---

...

------------------
Ciao,
Marc

[Diese Nachricht wurde von marc.scherer am 18. Mrz. 2005 editiert.]

[Diese Nachricht wurde von marc.scherer am 18. Mrz. 2005 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Marc,

also das TXT_SET.LSP

benutze ich schon seit ein paar Jahren und das funzt sehr gut :-))

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Nur mal der Vollständigkeit wegen eine korrektur.

Unter der in diesem Lisp angegebenen Adresse bekommt man mich nicht mehr. Meine aktuellen Kontaktdaten findet man: hier

Grüße Holger

------------------
Holger Brischke
CAD on demand GmbH                              Autodesk User Group Central Europe
Individuelle Lösungen von Heute auf Morgen.              AUGCE Manager Deutschland

[Diese Nachricht wurde von Brischke am 18. Mrz. 2005 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Zitat:

---

Original schrub:
Hi Marc,

also das TXT_SET.LSP

benutze ich schon seit ein paar Jahren und das funzt sehr gut :-))

---

Wußte ich doch, dass ich das schon mal gepostet hatte...

------------------
Ciao,
Marc

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Marc

DANKE ich fliege vor Freude... mein Wochenende ist gerettet..
mein Erfolgserlebnis fuer diese Woche verdanke ich Dir 

lg Dimy

------------------
geht nicht.. gibts nicht

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

@Dimitra:
Ja, sacht meine Frau auch immer ;-)...

------------------
Ciao,
Marc

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP