Hot News:

Mit Unterstützung durch:

  Foren auf CAD.de (alle Foren)
  Rund um AutoCAD
  tal lisp umschreiben ?

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  tal lisp umschreiben ? (545 mal gelesen)
Dimitra75
Mitglied
Bauzeichnerin


Sehen Sie sich das Profil von Dimitra75 an!   Senden Sie eine Private Message an Dimitra75  Schreiben Sie einen Gästebucheintrag für Dimitra75

Beiträge: 58
Registriert: 14.03.2005

ACAD 2014
Windows 7

erstellt am: 18. Mrz. 2005 09:41    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


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

CADmium
Moderator
Maschinenbaukonstrukteur




Sehen Sie sich das Profil von CADmium an!   Senden Sie eine Private Message an CADmium  Schreiben Sie einen Gästebucheintrag für CADmium

Beiträge: 13508
Registriert: 30.11.2003

Hinweis: Meine Mitarbeit auf CAD.DE ist fakultativ, unentgeltlich und beruht nur auf einem ausgeprägtem Helfersyndrom.

erstellt am: 18. Mrz. 2005 11:51    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

marc.scherer
Ehrenmitglied V.I.P. h.c.
CAD-Administrator



Sehen Sie sich das Profil von marc.scherer an!   Senden Sie eine Private Message an marc.scherer  Schreiben Sie einen Gästebucheintrag für marc.scherer

Beiträge: 2490
Registriert: 02.11.2001

Windows 10 64bit
AutoCAD Architecture 2018/2019 (deu/eng)
AEC-Collection 2019 (Revit und Zeugs)
Wenn sich's nicht vermeiden läßt:
D-A-CH Erweiterung (mies implementierter Schrott)

erstellt am: 18. Mrz. 2005 13:06    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

Dimitra75
Mitglied
Bauzeichnerin


Sehen Sie sich das Profil von Dimitra75 an!   Senden Sie eine Private Message an Dimitra75  Schreiben Sie einen Gästebucheintrag für Dimitra75

Beiträge: 58
Registriert: 14.03.2005

erstellt am: 18. Mrz. 2005 13:09    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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

CADmium
Moderator
Maschinenbaukonstrukteur




Sehen Sie sich das Profil von CADmium an!   Senden Sie eine Private Message an CADmium  Schreiben Sie einen Gästebucheintrag für CADmium

Beiträge: 13508
Registriert: 30.11.2003

Hinweis: Meine Mitarbeit auf CAD.DE ist fakultativ, unentgeltlich und beruht nur auf einem ausgeprägtem Helfersyndrom.

erstellt am: 18. Mrz. 2005 13:20    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

AsSchu
Ehrenmitglied
Konstrukteur


Sehen Sie sich das Profil von AsSchu an!   Senden Sie eine Private Message an AsSchu  Schreiben Sie einen Gästebucheintrag für AsSchu

Beiträge: 1632
Registriert: 27.06.2003

ACAD 2012

erstellt am: 18. Mrz. 2005 13:24    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

marc.scherer
Ehrenmitglied V.I.P. h.c.
CAD-Administrator



Sehen Sie sich das Profil von marc.scherer an!   Senden Sie eine Private Message an marc.scherer  Schreiben Sie einen Gästebucheintrag für marc.scherer

Beiträge: 2490
Registriert: 02.11.2001

Windows 10 64bit
AutoCAD Architecture 2018/2019 (deu/eng)
AEC-Collection 2019 (Revit und Zeugs)
Wenn sich's nicht vermeiden läßt:
D-A-CH Erweiterung (mies implementierter Schrott)

erstellt am: 18. Mrz. 2005 13:28    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

AsSchu
Ehrenmitglied
Konstrukteur


Sehen Sie sich das Profil von AsSchu an!   Senden Sie eine Private Message an AsSchu  Schreiben Sie einen Gästebucheintrag für AsSchu

Beiträge: 1632
Registriert: 27.06.2003

ACAD 2012

erstellt am: 18. Mrz. 2005 13:33    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

Brischke
Ehrenmitglied V.I.P. h.c.
CAD on demand GmbH



Sehen Sie sich das Profil von Brischke an!   Senden Sie eine Private Message an Brischke  Schreiben Sie einen Gästebucheintrag für Brischke

Beiträge: 4171
Registriert: 17.05.2001

AutoCAD 20XX, defun-tools

erstellt am: 18. Mrz. 2005 13:33    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

marc.scherer
Ehrenmitglied V.I.P. h.c.
CAD-Administrator



Sehen Sie sich das Profil von marc.scherer an!   Senden Sie eine Private Message an marc.scherer  Schreiben Sie einen Gästebucheintrag für marc.scherer

Beiträge: 2490
Registriert: 02.11.2001

Windows 10 64bit
AutoCAD Architecture 2018/2019 (deu/eng)
AEC-Collection 2019 (Revit und Zeugs)
Wenn sich's nicht vermeiden läßt:
D-A-CH Erweiterung (mies implementierter Schrott)

erstellt am: 18. Mrz. 2005 13:37    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

Dimitra75
Mitglied
Bauzeichnerin


Sehen Sie sich das Profil von Dimitra75 an!   Senden Sie eine Private Message an Dimitra75  Schreiben Sie einen Gästebucheintrag für Dimitra75

Beiträge: 58
Registriert: 14.03.2005

erstellt am: 18. Mrz. 2005 13:41    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

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



Praktikant (m/w/d) im Systems Engineering / Mechatronik

WEINMANN Emergency, seit über 100 Jahren tätig, ist ein international tätiges Medizintechnik-Unternehmen in Familienbesitz, mit ca. 350 Mitarbeiter*innen. An unseren Standorten in Hamburg und Henstedt-Ulzburg entwickeln und produzieren wir innovative Medizinprodukte im Bereich der Notfallmedizin und leisten somit einen wichtigen Beitrag zur Rettung von Menschenleben.


  • Du begleitest ...
Anzeige ansehenMedizintechnik
marc.scherer
Ehrenmitglied V.I.P. h.c.
CAD-Administrator



Sehen Sie sich das Profil von marc.scherer an!   Senden Sie eine Private Message an marc.scherer  Schreiben Sie einen Gästebucheintrag für marc.scherer

Beiträge: 2490
Registriert: 02.11.2001

Windows 10 64bit
AutoCAD Architecture 2018/2019 (deu/eng)
AEC-Collection 2019 (Revit und Zeugs)
Wenn sich's nicht vermeiden läßt:
D-A-CH Erweiterung (mies implementierter Schrott)

erstellt am: 18. Mrz. 2005 13:51    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dimitra75 10 Unities + Antwort hilfreich

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

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

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz