Stationierung von Pline, Line und Spline... (Autodesk/Lisp)

Hi,
ich habe das Thema mal für mich behandeln müssen...
Anbei die Ergebnisse zur freien Verfügung.
Eigene Stationierungs-Lösungen sollten sich relativ einfach lösen lassen, da die sub-function "MS:STATION" ziemlich viele Parameter zuläßt. In einem eigenen defun c: kann man dann festlegen, welch Variablen man Abfragen will, und welche fest eingestellt sein sollen.
Einfach mal meine defun c:'s checken.
Einige Dinge sind auskommentiert um das Pgm zu verallgemeinern (z.B. Das setzen der Layer...).

Code:

(defun C:STATION (/    L    M    OERR OSM
OCE    SELECT STAT TEXTHÖHE? TEXTPREFIX
TEXTSUFFIX
   )
(defun *STAT_ERR* (S)
(command "_.UNDO" "_End")
(setvar "OSMODE" OSM)
(setvar "cmdecho" OCE)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
;; Neue Fehlerfunktion aktivieren:
(setq OERR *ERROR*
*ERROR* *STAT_ERR*
OSM    (getvar "OSMODE")
OCE    (getvar "cmdecho")
) ;_ end of setq

;; VORGABEWERTE:
(setq STAT 100.0 ;_ Vorgabewert für Stationierungsinkrement
M 1 ;_ Vorgabewert für Textmaßstab
TEXTHÖHE? 1.25
TEXTPREFIX
   ""
TEXTSUFFIX
   ""
) ;_ end of setq
(setvar "OSMODE" 0)
(setvar "cmdecho" 0)
;;; (MS:STAT-LAYER) ;_ Layer setzen
;;; (if (/= (tblsearch "style" "SIMPLEX") NIL) ;_ Textstil setzen
;;; (setvar "textstyle" "SIMPLEX")
;;; ) ;_ end of if
(if (not
(setq
L (getreal "\nWert für Anfangsstationierung eingeben <0>: ")
) ;_ end of setq
) ;_ end of not
(setq L 0)
) ;_ end of if
;; Undo-Gruppe erstellen:
(command "_.UNDO" "_End" "_.UNDO" "_Group")
(command "_.ucs" "_w")
(if (not (setq SELECT
(entsel
"\nZu Stationierendes Objekt (Linie, Polylinie oder Spline) wählen: "
) ;_ end of entsel
   ) ;_ end of setq
) ;_ end of not
(princ "\nKein Objekt gewählt! Funktionsende.")
(if (not (member (cdr (assoc 0 (entget (car SELECT))))
   '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE")
   ) ;_ end of member
) ;_ end of not
(princ
"\nObjekt war weder Linie, Polylinie noch Spline! Funktionsende."
) ;_ end of princ
(MS:STATION
(car SELECT) ;_ Objname
(cadr SELECT) ;_ geklickter Punkt
L ;_ Anfangs-Station
STAT ;_ Stationierungsinkrement
M ;_ Maßstab für Texteintragungen
TEXTHÖHE? ;_ Texthöhe
TEXTPREFIX ;_ Präfix für Text
TEXTSUFFIX ;_ Suffix für Text
2 ;_ Textausrichtungs-Modus (hier: Immer in Stationierungsrichtung)
2
) ;_ end of MS:STATION
) ;_ end of if
) ;_ end of if
;; Undo-Gruppe beenden:
(command "_.UNDO" "_End")
;; Systemvariablen zuruecksetzen:
(setvar "OSMODE" OSM)
(setvar "cmdecho" OCE)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
(defun C:STATION2 (/    L    M    OERR OSM
   OCE    SELECT STAT TEXTHÖHE? TEXTPREFIX
   TEXTSUFFIX
)
(defun *STAT_ERR* (S)
(command "_.UNDO" "_End")
(setvar "OSMODE" OSM)
(setvar "CMDECHO" OCE)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
;; Neue Fehlerfunktion aktivieren:
(setq OERR *ERROR*
*ERROR* *STAT_ERR*
OSM    (getvar "OSMODE")
OCE    (getvar "CMDECHO")
) ;_ end of setq

;; VORGABEWERTE:
(setq M 1 ;_ Vorgabewert für Textmaßstab
TEXTPREFIX
   ""
TEXTSUFFIX
   ""
) ;_ end of setq
(setvar "OSMODE" 0)
(setvar "CMDECHO" 0)
;;; (MS:STAT-LAYER) ;_ Layer setzen
;;; (if (/= (tblsearch "style" "SIMPLEX") NIL) ;_ Textstil setzen
;;; (setvar "textstyle" "SIMPLEX")
;;; ) ;_ end of if
(if (not
(setq
L (getdist
"\nWert für Anfangsstationierung eingeben/picken <0>: "
) ;_ end of getdist
) ;_ end of setq
) ;_ end of not
(setq L 0)
) ;_ end of if
(if (not (setq STAT
(getdist
"\nWert für Stationierungs-Inkrement eingeben/picken <100.0>: "
) ;_ end of getdist
   ) ;_ end of setq
) ;_ end of not
(setq STAT 100.0)
) ;_ end of if
(if (not (setq TEXTHÖHE?
(getdist "\nWert für Texthöhe eingeben/picken <1.25>: "
) ;_ end of getdist
   ) ;_ end of setq
) ;_ end of not
(setq TEXTHÖHE? 1.25)
) ;_ end of if
;; Undo-Gruppe erstellen:
(command "_.UNDO" "_End" "_.UNDO" "_Group")
(command "_.ucs" "_w")
(if (not (setq SELECT
(entsel
"\nZu Stationierendes Objekt (Linie, Polylinie oder Spline) wählen: "
) ;_ end of entsel
   ) ;_ end of setq
) ;_ end of not
(princ "\nKein Objekt gewählt! Funktionsende.")
(if (not (member (cdr (assoc 0 (entget (car SELECT))))
   '("LINE" "POLYLINE" "LWPOLYLINE" "SPLINE")
   ) ;_ end of member
) ;_ end of not
(princ
"\nObjekt war weder Linie, Polylinie noch Spline! Funktionsende."
) ;_ end of princ
(MS:STATION
(car SELECT) ;_ Objname
(cadr SELECT) ;_ geklickter Punkt
L ;_ Anfangs-Station
STAT ;_ Stationierungsinkrement
M ;_ Maßstab für Texteintragungen
TEXTHÖHE? ;_ Texthöhe
TEXTPREFIX ;_ Präfix für Text
TEXTSUFFIX ;_ Suffix für Text
2 ;_ Textausrichtungs-Modus (hier: Immer in Stationierungsrichtung)
2
) ;_ end of MS:STATION
) ;_ end of if
) ;_ end of if
;; Undo-Gruppe beenden:
(command "_.UNDO" "_End")
;; Systemvariablen zuruecksetzen:
(setvar "OSMODE" OSM)
(setvar "CMDECHO" OCE)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun

(defun C:STATION-FROM (/    BEGIN-AT PRECISION   SCALING
   TEXTMODE TXTPREFIX   TXTSIZE    TXTSUFFIX
)
(defun *STAT_ERR* (S)
(setvar "OSMODE" OSM)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
;; Neue Fehlerfunktion aktivieren:
(setq OERR *ERROR*
*ERROR* *STAT_ERR*
OSM    (getvar "OSMODE")
) ;_ end of setq
(setvar "OSMODE" 0)
;;; (MS:STAT-LAYER) ;_ Layer setzen
;;; (if (/= (tblsearch "style" "SIMPLEX") NIL) ;_ Textstil setzen
;;; (setvar "textstyle" "SIMPLEX")
;;; ) ;_ end of if
;; VORGABEWERTE:
(setq BEGIN-AT 0
SCALING 1
TXTSIZE 1.25
TXTPREFIX ""
TXTSUFFIX ""
TEXTMODE 2
PRECISION 2
) ;_ end of setq
(MS:STATION-FROM
BEGIN-AT SCALING TXTSIZE TXTPREFIX TXTSUFFIX TEXTMODE PRECISION) ;_ end of MS:STATION-FROM
;_ end of MS:STATION-FROM
(setvar "OSMODE" OSM)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
(defun C:STATION-FROM2 (/    BEGIN-AT PRECISION   SCALING
TEXTMODE TXTPREFIX   TXTSIZE    TXTSUFFIX
   )
(defun *STAT_ERR* (S)
(setvar "OSMODE" OSM)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun
;; Neue Fehlerfunktion aktivieren:
(setq OERR *ERROR*
*ERROR* *STAT_ERR*
OSM    (getvar "OSMODE")
) ;_ end of setq
(setvar "OSMODE" 0)
;;; (MS:STAT-LAYER) ;_ Layer setzen
;;; (if (/= (tblsearch "style" "SIMPLEX") NIL) ;_ Textstil setzen
;;; (setvar "textstyle" "SIMPLEX")
;;; ) ;_ end of if
(if (not
(setq
BEGIN-AT
   (getdist
   "\nWert für Anfangsstationierung eingeben/picken <0>: "
   ) ;_ end of getdist
) ;_ end of setq
) ;_ end of not
(setq BEGIN-AT 0)
) ;_ end of if
(if (not (setq TXTSIZE
(getdist "\nWert für Texthöhe eingeben/picken <1.25>: ")
   ) ;_ end of setq
) ;_ end of not
(setq TXTSIZE 1.25)
) ;_ end of if
(setq TXTPREFIX ""
TXTSUFFIX ""
SCALING 1.0
TEXTMODE 2
PRECISION 2
) ;_ end of setq
(MS:STATION-FROM
BEGIN-AT SCALING TXTSIZE TXTPREFIX TXTSUFFIX TEXTMODE PRECISION) ;_ end of MS:STATION-FROM
;_ end of MS:STATION-FROM
(setvar "OSMODE" OSM)
(setq *ERROR* OERR)
(princ)
) ;_ end of defun

(defun C:TEST (/ INKREMENT? MODE? OBJ? PKT? PREFIX? SEL SKALIERUNG? STARTWERT? SUFFIX? TXTGRÖßE? PRÄZISION?)
(setq SEL (entsel))
(if SEL
(progn
(setq OBJ? (car SEL)
PKT? (cadr SEL)
STARTWERT? (getdist "\nStartwert für Stationierung eingeben/picken: ")
SKALIERUNG? (getreal "\nMaßstab für Stationierung eingeben: ")
INKREMENT? (getdist "\nInkrement für Stationierung eingeben/picken: ")
TXTGRÖßE?   (getdist "\nTexthöhe für Stationierung eingeben/picken: ")
PRÄZISION? (getint "\nAnzahl Nachkommastellen? (0-8): ")
PREFIX?    (getstring t "\nPrefix: ")
SUFFIX?    (getstring t "\nSuffix: ")
) ;_ end of setq
(initget "Ja Nein")
(setq MODE? (getkword "\nTextausrichtung immer in Stationierungsrichtung? [Ja/Nein] <Ja>: "))
(if (not mode?)
(setq mode? "Ja")
)
(if (= mode? "Ja")
(setq mode? 2)
(setq mode? 1)
)
(MS:STATION OBJ? PKT? STARTWERT? INKREMENT? SKALIERUNG? TXTGRÖßE? PREFIX? SUFFIX? mode? PRÄZISION?)
) ;_ end of progn
) ;_ end of if
)
(defun C:TEST2 (/ MODE? PREFIX? PRÄZISION?
SKALIERUNG? STARTWERT?   SUFFIX? TXTGRÖßE?
   )
(setq STARTWERT? (getdist "\nStartwert für Stationierung eingeben/picken: "
) ;_ end of getdist
SKALIERUNG? (getreal "\nMaßstab für Stationierung eingeben: ")
TXTGRÖßE?   (getdist "\nTexthöhe für Stationierung eingeben/picken: ")
PRÄZISION? (getint "\nAnzahl Nachkommastellen? (0-8): ")
PREFIX?    (getstring t "\nPrefix: ")
SUFFIX?    (getstring t "\nSuffix: ")
) ;_ end of setq
(initget "Ja Nein")
(setq MODE?
   (getkword
   "\nTextausrichtung immer in Stationierungsrichtung? [Ja/Nein] <Ja>: "
   ) ;_ end of getkword
) ;_ end of setq
(if (not MODE?)
(setq MODE? "Ja")
) ;_ end of if
(if (= MODE? "Ja")
(setq MODE? 2)
(setq MODE? 1)
) ;_ end of if
(MS:STATION-FROM
STARTWERT? SKALIERUNG? TXTGRÖßE? PREFIX? SUFFIX? MODE? PRÄZISION?) ;_ end of MS:STATION-FROM
;_ end of MS:STATION-FROM
;_ end of MS:STATION-FROM
(princ)
)
;;; ************ Sub-Routines **********************
(vl-load-com)
;;; Startparameter für MS:STATION
;;; objname = Lisp-Objektname der Polylinie
;;; begin-at   = Startwert für Stationierung
;;; increment = Stationierungsinkrement
;;; scaling = Maßstabs-Faktor für Inkrement-Werte
;;; txtsize = Textgröße
;;; txtprefix = Präfix für numerischen Wert
;;; txtsuffix = Suffix für numerischen Wert
;;; TEXTMODE   = Steuert die Ausrichtung der Textobjekte 1 = Immer lesbar 2= In Stationierungsrichtung
;;; PRECISION = Steuert die Anzahl der Nachkomma-Stellen 0-8 ist möglich (wie luprec).
;;; Werte über acht werden auf 8 gesetzt
(defun MS:STATION (OBJNAME PICKPT    BEGIN-AT    INCREMENT
   SCALING TXTSIZE TXTPREFIX TXTSUFFIX TEXTMODE PRECISION
   / END-PKT INDEX OBJLENGTH
   PARTS REVERSED    START-PKT STATION-LST
   VLA-OBJNAME
)
(setq OBJLENGTH   (LIN-LENGTH? OBJNAME)
INCREMENT   (float INCREMENT)
PARTS    (fix (/ OBJLENGTH INCREMENT)) ;_ Anzahl der Teile in integer
VLA-OBJNAME (vlax-ename->vla-object OBJNAME)
INDEX    1
) ;_ end of setq
(if (IS-AT-START? OBJNAME PICKPT) ;_ gegen Erstellungsrichtung arbeiten oder in Erstellungsrichtung
(setq START-PKT (vlax-curve-getstartpoint VLA-OBJNAME)
END-PKT   (vlax-curve-getendpoint VLA-OBJNAME)
REVERSED NIL
) ;_ end of setq
(setq END-PKT   (vlax-curve-getstartpoint VLA-OBJNAME)
START-PKT (vlax-curve-getendpoint VLA-OBJNAME)
REVERSED t
) ;_ end of setq
) ;_ end of if
(if (> TEXTMODE 1)
(if REVERSED
(setq TEXTMODE 3)
) ;_ end of if
) ;_ end of if
(MS:STATIONPLACING
VLA-OBJNAME
START-PKT
(strcat TXTPREFIX
(MS:REFORMAT-TXT
(rtos (* (+ 0.0 BEGIN-AT) SCALING) 2 PRECISION)
"."
PRECISION
) ;_ end of MS:REFORMAT-TXT
TXTSUFFIX
) ;_ end of strcat
TXTSIZE
TEXTMODE
) ;_ end of MS:STATIONPLACING
(MS:STATIONPLACING
VLA-OBJNAME
END-PKT
(strcat TXTPREFIX
(MS:REFORMAT-TXT
(rtos (* (+ OBJLENGTH BEGIN-AT) SCALING)
2
PRECISION
) ;_ end of rtos
"."
PRECISION
) ;_ end of MS:REFORMAT-TXT
TXTSUFFIX
) ;_ end of strcat
TXTSIZE
TEXTMODE
) ;_ end of MS:STATIONPLACING
(if (not (zerop PARTS))
(progn
(repeat PARTS
(setq STATION-LST (cons (* INCREMENT INDEX)
STATION-LST
) ;_ end of cons
INDEX    (1+ INDEX)
) ;_ end of setq
) ;_ end of repeat
(setq STATION-LST (reverse STATION-LST))
(foreach ELEM STATION-LST
(MS:STATIONPLACING
VLA-OBJNAME
(CALCULATE-INSERTATION OBJNAME PICKPT ELEM)
(strcat TXTPREFIX
(MS:REFORMAT-TXT
(rtos (* (+ ELEM BEGIN-AT) SCALING)
2
PRECISION
) ;_ end of rtos
"."
PRECISION
) ;_ end of MS:REFORMAT-TXT
TXTSUFFIX
) ;_ end of strcat
TXTSIZE
TEXTMODE
) ;_ end of MS:STATIONPLACING
) ;_ end of foreach
(princ (strcat "\nOK, >"
   (itoa (+ PARTS 2))
   "< Stationierungen eingefügt!"
   ) ;_ end of strcat
) ;_ end of princ
) ;_ end of progn
(princ "\nOK, >2< Stationierungen eingefügt!")
) ;_ end of if
) ;_ end of defun

;;; Stationierung nach geklicktem Punkt
(defun MS:STATION-FROM (BEGIN-AT SCALING    TXTSIZE    TXTPREFIX
TXTSUFFIX   TEXTMODE PRECISION   /
   )
(defun DOLOOP (SELECTED /)
(setq OBJNAME (car SELECTED)
PICKPT (cadr SELECTED)
PL (vlax-ename->vla-object OBJNAME)
) ;_ end of setq
(if (IS-AT-START? OBJNAME PICKPT) ;_ gegen Erstellungsrichtung arbeiten oder in Erstellungsrichtung
(setq REVERSED NIL) ;_ end of setq
(setq REVERSED t) ;_ end of setq
) ;_ end of if
(if (> TEXTMODE 1)
(if REVERSED
(setq TEXTMODE 3)
) ;_ end of if
) ;_ end of if
(while (setq PT (getpoint "\nPunkt für Station wählen: "))
(setq CPT (vlax-curve-getclosestpointto PL PT))
(if (not REVERSED)
(setq LEN (vlax-curve-getdistatpoint PL CPT))
(setq
LEN (- (LIN-LENGTH? OBJNAME)
   (vlax-curve-getdistatpoint PL CPT)
) ;_ end of -
) ;_ end of setq
) ;_ end of if
(setq IPT (CALCULATE-INSERTATION OBJNAME PICKPT LEN))
(if (or (equal CPT (vlax-curve-getendpoint PL)) ;_ wenn der berechnete Einfügepunkt auf End-oder Startpunkt liegt,
(equal CPT (vlax-curve-getstartpoint PL))
) ;_ end of or
(if (not (equal CPT PT)) ;_ ...und dann der gepickte Punkt nicht auch dort war (OFang!),
(princ
"\nGeklickter Punkt war VOR Startpunkt oder HINTER Endpunkt des linearen Objekts..."
) ;_ end of princ
(progn
(if (equal CPT (vlax-curve-getendpoint PL))
(setq INS-PKT (vlax-curve-getendpoint PL))
(setq INS-PKT (vlax-curve-getstartpoint PL))
) ;_ end of if
(MS:STATIONPLACING
PL
INS-PKT
(strcat TXTPREFIX
(MS:REFORMAT-TXT
(rtos (* (+ LEN BEGIN-AT) SCALING)
2
PRECISION
) ;_ end of rtos
"."
PRECISION
) ;_ end of MS:REFORMAT-TXT
TXTSUFFIX
) ;_ end of strcat
TXTSIZE
TEXTMODE
) ;_ end of MS:STATIONPLACING
) ;_ end of progn
) ;_ end of if
(MS:STATIONPLACING
PL
IPT
(strcat TXTPREFIX
(MS:REFORMAT-TXT
(rtos (* (+ LEN BEGIN-AT) SCALING)
2
PRECISION
) ;_ end of rtos
"."
PRECISION
) ;_ end of MS:REFORMAT-TXT
TXTSUFFIX
) ;_ end of strcat
TXTSIZE
TEXTMODE
) ;_ end of MS:STATIONPLACING
) ;_ end of if
) ;_ end while
) ;_ end defun
(princ "\nZu Stationierendes Objekt (Linie, Polylinie oder Spline) wählen: ")
(if (setq EP (entsel))
(DOLOOP EP)
) ;_ end if
(princ)
) ;_ end of defun
(defun MS:REFORMAT-TXT (LTXT    DELIMITER PRECISION /
DECIMAL FRST    POST-DEC   REAL
REST    RETVAL    SUBSTRACTION
TEILER OLD-DIMZIN OLD-LUPREC
   )
(setq OLD-DIMZIN (getvar "dimzin")
OLD-LUPREC (getvar "luprec")
) ;_ end of setq
(setvar "dimzin" 1)
(if (> PRECISION 8)
(setq PRECISION 8)
) ;_ end of if
(setvar "luprec" PRECISION)
(setq LTXT (rtos (atof LTXT) 2 PRECISION))
(if (setq DECIMAL (vl-string-position (ascii ".") LTXT))
(setq
POST-DEC (substr
   (rtos (- (atof LTXT) (atoi (substr LTXT 1 DECIMAL)))
   2
   PRECISION
   ) ;_ end of rtos
   3
   ) ;_ end of substr
) ;_ end of setq
(setq POST-DEC "")
) ;_ end of if
(setq TEILER    1000.0
REAL    (atof LTXT)
FRST    (fix (/ REAL TEILER))
SUBSTRACTION (* FRST TEILER)
REST    (itoa (fix (- REAL SUBSTRACTION)))
) ;_ end of setq
(if (not (zerop PRECISION))
(setq RETVAL (strcat (itoa FRST)
   " +"
   (MS:MK000 REST 3)
   DELIMITER
   (MS:MK000 POST-DEC PRECISION)
   ) ;_ end of strcat
) ;_ end of setq
(setq RETVAL (strcat (itoa FRST)
   " +"
   (MS:MK000 REST 3)
   ) ;_ end of strcat
) ;_ end of setq
) ;_ end of if
(setvar "dimzin" OLD-DIMZIN)
(setvar "luprec" OLD-LUPREC)
RETVAL
) ;_ end of defun
(defun MS:MK000 (WRT ANZAHL /)
(if (not (zerop ANZAHL))
(if (/ (strlen WRT) ANZAHL)
(repeat (- ANZAHL (strlen WRT))
(setq WRT (strcat "0" WRT))
) ;_ end of repeat
) ;_ end of if
(setq wrt "")
) ;_ end of if
WRT
) ;_ end of defun

;;; Mode steuert wie die Texte plaziert werden
;;; Mode = 1 Texte sind immer von vorne und rechts lesbar
;;; Mode = 2 Texte sind immer in Stationierungsrichtung, Polylinie wird in Erstellungsrichtung stationiert
;;; Mode = 3 Texte sind immer in Stationierungsrichtung, Polylinie wird GEGEN Erstellungsrichtung stationiert
(defun MS:STATIONPLACING
   (PL PT TXT TXTSIZE MODE / ANG FD MS PAR PT2 TO TXL)
(if (not PT)
(princ "\nUngültig!")
(progn
(setq MS (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-modelspace
TXL (* TXTSIZE (+ (strlen TXT) 2))
PT (vlax-curve-getclosestpointto PL PT)
PAR (vlax-curve-getparamatpoint PL PT)
FD (vlax-curve-getfirstderiv PL PAR)
ANG (angle '(0 0 0) FD)
) ;_ end of setq
(cond
((= MODE 1)
   (setq ANG (if (> ANG pi)
   (+ ANG (/ pi 2))
   (- ANG (/ pi 2))
   ) ;_ end of if
   ) ;_ end of setq
)
((= MODE 2)
   (setq ANG (- ANG (/ pi 2))
   ) ;_ end of setq
)
((= MODE 3)
   (setq ANG (+ ANG (/ pi 2))
   ) ;_ end of setq
)
) ;_ end of cond
(setq PT2 (polar PT ANG TXL))
(vla-addline MS (vlax-3d-point PT) (vlax-3d-point PT2))
(setq TO (vla-addtext
   MS
   TXT
   (vlax-3d-point '(0 0 0))
   TXTSIZE
   ) ;_ end vla-addtext
) ;_ end setq
(vla-put-alignment TO acalignmentbottomright)
(vla-put-rotation TO ANG)
(vla-put-textalignmentpoint TO (vlax-3d-point PT2))
) ;_ end of progn
) ;_ end of if
) ;_ end of defun

(princ "\nStationierungsroutinen")
(princ "\nAufruf: STATION[2], STATION-FROM[2] oder TEST[2]")
(princ)
;|
**********************************************************************
**    POLYLINIEN-HANDLING **
**********************************************************************
Allgemeine Funktionen zum Handeln von LW und Polylinienobjekten.
Alle folgenden Funktionen sollen zukünftig von anderen Pgmen. dazu
benutzt werden Daten aus Polylinienobjekten zu ziehen, bzw. Punkte
zu berechnen usw.
Es finden in den Funktionen keinerlei Prüfungen auf Objekttypen statt.
D.h. dies muß die rufende Funktion übernehmen.
|;
;;; Active-X Extensions laden
;;;(vl-load-com)
;;; Punkt finden, der in einem bestimmten Abstand zum Startpunkt liegt.
;;; IN RICHTUNG des linearen Objektes.
;;; -> Abstand, Element
;;; <- Welt-Koordinate oder nil (wenn nicht auf Element!)
(defun FIND-PT (ENAME ABSTAND /)
(vlax-curve-getpointatdist
(vlax-ename->vla-object ENAME)
ABSTAND
) ;_ end of vlax-curve-getpointatdist
) ;_ end of defun
;;; Punkt finden, der in einem bestimmten Abstand zum ENDpunkt liegt.
;;; IN RICHTUNG des linearen Objektes.
;;; -> Abstand, Element
;;; <- Welt-Koordinate oder nil (wenn nicht auf Element!)
(defun FIND-PT-REVERSE (ENAME ABSTAND /)
(setq ENAME (vlax-ename->vla-object ENAME))
(vlax-curve-getpointatdist
ENAME
;; Differenz zwischen Geamtlänge des Elements
;; und Distanz ergiebt Länge vom Startpunkt
(- (vlax-curve-getdistatparam
   ENAME
   (vlax-curve-getendparam ENAME)
   ) ;_ end of vlax-curve-getdistatparam
   ABSTAND
) ;_ end of -
) ;_ end of vlax-curve-getpointatdist
) ;_ end of defun

;;; Punkt finden, der in einem Abstand RELATIV zu einem Punkt
;;; auf dem linearen Objekt liegt.
;;; Abstand NEGATIV angeben für relativ ENTGEGEGEN der Richtung!
;;; -> Abstand, Element, Startpunkt
;;; <- Welt-Koordinate oder nil (wenn nicht auf Element!)
(defun FIND-PT-RELATIVE (ENAME PKT ABSTAND /)
(setq ENAME (vlax-ename->vla-object ENAME))
(vlax-curve-getpointatdist
ENAME
(+ (vlax-curve-getdistatpoint
   ENAME
   (vlax-curve-getclosestpointto
   ENAME
   PKT
   ) ;_ end of vlax-curve-getclosestpointto
   ) ;_ end of vlax-curve-getdistatpoint
   ABSTAND
) ;_ end of +
) ;_ end of vlax-curve-getpointatdist
) ;_ end of defun
;;; Berechnung der Länge zwischen zwei Punkten
;;; die auf einer Polylinie liegen
;;; -> Punkt1, Punkt2 und Elementname
;;; <- Länge zwischen diesen Punkten
(defun 2P-DIST (ENAME PT1 PT2 /)
(setq ENAME (vlax-ename->vla-object ENAME))
(abs (- (vlax-curve-getdistatpoint
ENAME
(vlax-curve-getclosestpointto
ENAME
PT1
) ;_ end of vlax-curve-getclosestpointto
) ;_ end of vlax-curve-getDistAtPoint
(vlax-curve-getdistatpoint
ENAME
(vlax-curve-getclosestpointto
ENAME
PT2
) ;_ end of vlax-curve-getClosestPointTo
) ;_ end of vlax-curve-getdistatpoint
   ) ;_ end of -
) ;_ end of abs
) ;_ end of defun

;;; Länge eines linearen Objektes berechnen:
;;; -> Elementname
;;; <- Länge des linearen Elements
(defun LIN-LENGTH? (ENAME /)
(setq ENAME (vlax-ename->vla-object ENAME))
(vlax-curve-getdistatparam
ENAME
(vlax-curve-getendparam ENAME)
) ;_ end of vlax-curve-getdistatparam
) ;_ end of defun

;;; Fläche ermitteln, die lineares Objekt umschließt
(defun AREA? (ENAME /)
(vlax-curve-getarea (vlax-ename->vla-object ENAME))
) ;_ end of defun

;;; Endpunkt in WKS für lineares Objekt ermitteln
(defun END-PKT? (ENAME /)
(vlax-curve-getendpoint (vlax-ename->vla-object ENAME))
) ;_ end of defun
;;; Startpunkt in WKS für lineares Objekt ermitteln
(defun START-PKT? (ENAME /)
(vlax-curve-getstartpoint (vlax-ename->vla-object ENAME))
) ;_ end of defun
;;; Mittelpunkt in WKS für lineares Objekt ermitteln
(defun MITTEL-PKT? (ENAME /)
(setq ENAME (vlax-ename->vla-object ENAME))
(vlax-curve-getpointatdist
ENAME
(/ (vlax-curve-getdistatparam
   ENAME
   (vlax-curve-getendparam ENAME)
   ) ;_ end of vlax-curve-getdistatparam
   2.0
) ;_ end of /
) ;_ end of
) ;_ end of defun

;;; Identifizierung: Ist lineares Element geschlossen?
;;; -> Elementname
;;; <- T = geschlossen, nil = offen
(defun IS-CLOSED? (ENAME /)
(vlax-curve-isclosed (vlax-ename->vla-object ENAME))
) ;_ end of defun

;;; Identifizierung: Ist Ename eine Poyllinie?
;;; -> Elementname
;;; <- "POLYLINE", "LWPOLYLINE" oder nil
(defun IS-PL? (ENAME / RETVAL)
(if (wcmatch (setq RETVAL (cdr (assoc 0 (entget ENAME))))
   "POLYLINE,LWPOLYLINE"
) ;_ end of wcmatch
RETVAL
(setq RETVAL NIL)
) ;_ end of if
) ;_ end of defun

;;; Funktion ermittelt ob ein Punkt auf einem Element ist
;;; -> Punkt als Liste, Elementname
;;; <- Punkt als Liste oder nil
(defun IS-ON-PL? (ENAME PKT /)
(if (vlax-curve-getdistatpoint
(vlax-ename->vla-object ENAME)
PKT
) ;_ end of vlax-curve-getDistAtPoint
PKT
) ;_ end if
) ;_ end defun

;;; Funktion ermittelt, ob eine Polylinie Bögen enthält
;;; -> Elementname
;;; <- Integer = Anzahl der Bulges, nil = Nein
(defun HAS-BULGES? (ENAME / BULGES INDEX VERTS XENAME)
(setq VERTS (COUNT-PL-VERT ENAME)
XENAME (vlax-ename->vla-object ENAME)
INDEX 0
BULGES 0
) ;_ end of setq
(while (< INDEX VERTS)
(if (not (zerop (vlax-invoke-method XENAME 'GETBULGE INDEX)))
(setq BULGES (1+ BULGES))
) ;_ end of if
(setq INDEX (1+ INDEX))
) ;_ end of while
(if (zerop BULGES)
(setq BULGES NIL)
BULGES
) ;_ end of if
) ;_ end of defun

;;; Berechnet den Punkt auf einem linearen Objekt
;;; -> Obj = Elementname
;;; -> Pkt = Pickpunkt auf Element
;;; -> Abstand, der abzutragen ist
(defun CALCULATE-INSERTATION (OBJ PKT ABSTAND /)
(if (IS-AT-START? obj pkt)
(FIND-PT OBJ ABSTAND)
(FIND-PT-REVERSE obj ABSTAND)
) ;_ end of if
) ;_ end of defun
;;; ermittelt, ob der Pickpunkt näher am Start-oder End-Punkt des linearen Objekts war
;;; das ist wichtig für die Abstandsberechnung (gegen oder in Objektrichtung rechnen?)
;;; -> Obj = Elementname
;;; -> Pkt = Pickpunkt auf Element
(defun IS-AT-START? (OBJ PKT /)
(< (2P-DIST OBJ PKT (START-PKT? OBJ)) ;_ Ist der Pickpunkt näher am Startpunkt?
   (2P-DIST OBJ PKT (END-PKT? OBJ))
) ;_ end of <
) ;_ end of defun
;;; Berechnet den Winkel des Pline-Segments
;;; -> Obj = Elementname
;;; -> Pkt = Pickpunkt auf Element
;;; -> Inspkt = Punkt auf dem Objekt.
(defun CALCULATE-ANGLE (OBJ PKT inspkt / PKTLST WNKL)
(setq
PKTLST (VERTEX-SUCHEN OBJ (vlax-curve-getclosestpointto OBJ inspkt))
) ;_ end of setq
(if (IS-AT-START? obj pkt)
(setq wnkl (angle (car PKTLST) (cadr PKTLST)))
(setq wnkl (angle (cadr PKTLST) (car PKTLST)))
) ;_ end of if
;;; (setq wnkl (- wnkl (/ (* 2 pi) 4)))
;;; (list (polar inspkt wnkl 1.5) wnkl)
)

;;; Funktion zum Aufinden der Stützpunkte zwischen denen der übergebene Punkt liegt.
;;; Prinzip:
;;; "Alle Vertices in Entfernungen umrechnen,
;;; den gewählten Punkt ebenso, und dann sehen, wo er dazwischen liegt."
;;; -> Punkt, Ename
;;; <- Liste mit zwei Punkten (WCS) in Laufrichtung des linearen Elementes
;;; Oder aber nil (z.B. Punkt nicht auf Polyline)
;;; d.h. (car "Liste") = 1. Punkt und (cadr "Liste") = 2. Punkt
;;; Nicht Funktional bei geschlossener Polylinie
(defun VERTEX-SUCHEN (ENAME PUNKT /
ABSTAENDE DERABSTAND   DERDAVOR
EPOLYLINIE   LASTINLIST   LASTPT
PKTNACH PKTVOR    RETVAL=NIL!!!!
   )
(setq EPOLYLINIE (vlax-ename->vla-object ENAME)
ABSTAENDE (mapcar
   (function
   (lambda (VERTEX)
   (vlax-curve-getdistatpoint EPOLYLINIE VERTEX)
   ) ;_ end lambda
   ) ;_ end function
;;;    (mapcar 'cdr
;;;    (vl-remove-if-not
;;;    (function (lambda (PAIR) (= (car PAIR) 10)))
;;;    (entget ENAME)
;;;    ) ;_ end vl-remove-if-not
;;;    ) ;_ end mapcar
   (GET-PL-POINTS ENAME)
   ) ;_ end mapcar
DERABSTAND (vlax-curve-getdistatpoint EPOLYLINIE PUNKT)
) ;_ end setq
(if (and ABSTAENDE DERABSTAND) ;_ Wenn beide Werte ermittelt werden konnten...
(progn
(setq LASTINLIST (last ABSTAENDE) ;_ Sichern des letzten Wertes, für geschlossene PL!
DERDAVOR   (nth (- (length ABSTAENDE) 2) ABSTAENDE) ;_ Sichern des vorletzten Wertes, wenn PT auf letztem Punkt
) ;_ end of setq
(while ABSTAENDE
(if (> (cadr ABSTAENDE) DERABSTAND)
(setq PKTVOR (car ABSTAENDE)
PKTNACH   (cadr ABSTAENDE)
ABSTAENDE NIL
) ;_ end setq
(setq ABSTAENDE (cdr ABSTAENDE)) ;_ end of setq
) ;_ end if
) ;_ end while
;;; Achtung, Bug in "vlax-curve-getpointatdist" der letzte Punkt wird
;;; nicht zurückgegeben. Darum Umweg über "vlax-curve-getEndPoint",
;;; wenn der letzte Punkt nicht korrekt wiedergegeben wird.
;;; Alt:
;;; (list (vlax-curve-getpointatdist EPOLYLINIE PKTVOR)
;;; (vlax-curve-getpointatdist EPOLYLINIE PKTNACH)
;;; ) ;_ end list
(cond
((= DERABSTAND LASTINLIST) ;_ Wenn der Punkt exakt auf dem letzten Punkt liegt...
   (list (vlax-curve-getpointatdist EPOLYLINIE DERDAVOR)
   (vlax-curve-getendpoint EPOLYLINIE)
   ) ;_ end of list
)
((> DERABSTAND LASTINLIST) ;_ Handling für geschlossene Polyline !
   (list (vlax-curve-getpointatdist EPOLYLINIE LASTINLIST)
   (vlax-curve-getstartpoint EPOLYLINIE)
   ) ;_ end of list
)
(t
   (list
   (vlax-curve-getpointatdist EPOLYLINIE PKTVOR)
   (if
   (not
   (setq
   LASTPT (vlax-curve-getpointatdist EPOLYLINIE PKTNACH)
   ) ;_ end of setq
   ) ;_ end of not
(setq LASTPT (vlax-curve-getendpoint EPOLYLINIE))
LASTPT
   ) ;_ end of if
   ) ;_ end list
)
) ;_ end of cond
) ;_ end of progn
RETVAL=NIL!!!!
) ;_ end of if
) ;_ end defun
(defun C:TEST-VS (/ DATA PT1 PT2 RADI XX)
(princ "\nPolylinie auswählen: ")
(setq XX   (entsel)
RADI (/ (getvar "viewsize") 20)
) ;_ end of setq
(if XX
(progn
(setq XENAME (vlax-ename->vla-object (car XX))
PT    (vlax-curve-getclosestpointto XENAME (cadr XX))
DATA   (VERTEX-SUCHEN (car XX) PT)
) ;_ end of setq
(if (and (setq PT1 (car DATA)) (setq PT2 (cadr DATA)))
(progn
(setvar "cecolor" "1")
(command "_circle" PT1 RADI)
(setvar "cecolor" "3")
(command "_circle" PT2 RADI)
) ;_ end of progn
(princ "\nFehler bei Ermittlung...")
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(princ)
) ;_ end of defun

;;; Funktion ermittelt die Anzahl der Verticies für eine Polylinie
;;; Dabei ist "0" der erste Vertex
;;; -> Elementname
;;; <- Anzahl Kontrollpunkte
(defun COUNT-PL-VERT (ENAME /)
(if (IS-CLOSED? ENAME)
(COUNT-PL-POINTS ENAME)
(1- (COUNT-PL-POINTS ENAME))
) ;_ end of if
) ;_ end of defun
;;; Funktion zählt die Anzahl von Stützpunkten einer Polyline
(defun COUNT-PL-POINTS (ENAME /)
(if (= (cdr (assoc 0 (entget ENAME))) "LWPOLYLINE")
(COUNT-LW-PL-POINTS ENAME)
(COUNT-HW-PL-POINTS ENAME)
) ;_ end of if
) ;_ end of defun

;;; Sub-Function für COUNT-PL-POINTS
;;; Handelt LWPolylines
(defun COUNT-LW-PL-POINTS (ENAME /)
(cdr (assoc 90 (entget ENAME)))
) ;_ end of defun
;;; Sub-Function für COUNT-PL-POINTS
;;; Handelt Polylines
(defun COUNT-HW-PL-POINTS (ENAME / EDATA INDEX)
(setq INDEX 0)
(while (= (cdr (assoc 0 (setq EDATA (entget (entnext ENAME)))))
"VERTEX"
   ) ;_ end of =
(setq ENAME (entnext ENAME)
INDEX (1+ INDEX)
) ;_ end of setq
) ;_ end of while
) ;_ end of defun
;;; Liste mit Polylinienpunkten zurückgeben.
;;; -> Elementname
;;; <- Punktliste
(defun GET-PL-POINTS (ENAME /)
(if (= (cdr (assoc 0 (entget ENAME))) "LWPOLYLINE")
(GET-LW-PL-POINTS ENAME)
(GET-HW-PL-POINTS ENAME)
) ;_ end of if
) ;_ end of defun
;;; Sub-Sub-Function für "GET-PL-POINTS"
;;; Handling für POLYLINE
(defun GET-HW-PL-POINTS (ENAME / EDATA PTLISTE)
(while (= (cdr (assoc 0 (setq EDATA (entget (entnext ENAME)))))
"VERTEX"
   ) ;_ end of =
(setq PTLISTE (cons (cdr (assoc 10 EDATA)) PTLISTE)
ENAME   (entnext ENAME)
) ;_ end of setq
) ;_ end of while
(reverse PTLISTE)
) ;_ end of defun
;;;(defun GET-LW-PL-POINTS (ENAME / EDATA PTLISTE)
;;; (setq EDATA (vl-remove-if-not
;;; (function (lambda (PAIR) (= (car PAIR) 10)))
;;; (entget ENAME)
;;; ) ;_ end vl-remove-if-not
;;; ) ;_ end setq
;;; (foreach ELEM EDATA
;;; (setq PTLISTE (cons (vl-remove 10 ELEM) PTLISTE))
;;; ) ;_ end foreach
;;; (reverse PTLISTE)
;; ;_ end defun
;;; Axels Lösung
;;; Sub-Sub-Function für "GET-PL-POINTS"
;;; Handling für LWPOLYLINE
(defun GET-LW-PL-POINTS (ENAME /)
(mapcar 'cdr
(vl-remove-if-not
(function
(lambda (PAIR) (= (car PAIR) 10))
) ;_ end of function
(entget ENAME)
) ;_ end of vl-remove-if-not
) ;_ end of mapcar
) ;_ end of defun
(princ)

Viel Spaß damit.
Über Anregungungen und Kommentare würde ich mich wie immer freuen (oder auch ärgern ;-))

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

[Diese Nachricht wurde von marc.scherer am 24. Aug. 2005 editiert.]

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