Code:
;;; Globale Variable für Stationierungslayer
(setq $MS:STATLAY "P_$-TRASSIERUNG");;; Funktion zum Stationslayer setzen
(defun MS:STAT-LAYER ()
(if (not SETZLAYER)
(if (/= (load "set_lay" "err") "err")
(MS:STAT-LAYER)
) ;_ end of if
(if $MS:STATLAY
(SETZLAYER $MS:STATLAY)
) ;_ end of if
) ;_ end of if
) ;_ end of defun
(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
;;; Länge eines linearen Objektes berechnen:
;;; -> Elementname
;;; <- Länge des linearen Elements
(defun LIN-LENGTH? (ENAME /)
(setq ENAME (->VLA-OBJECT ENAME))
(vlax-curve-getdistatparam
ENAME
(vlax-curve-getendparam ENAME)
) ;_ end of vlax-curve-getdistatparam
) ;_ end of defun
;;; Funktion gibt Ename zurück, wenn Lisp-Objekt oder vla-Objekt
;;; übergeben worden sind. Ansonsten nil
(defun ->ENAME (ENAME /)
(cond
((= (type ENAME) 'VLA-OBJECT) (vlax-vla-object->ename ENAME))
((= (type ENAME) 'ENAME) ENAME)
(t NIL)
) ;_ end of cond
) ;_ end of defun
;;; Funktion gibt vla-Objekt zurück, wenn Lisp-Objekt oder vla-Objekt
;;; übergeben worden sind. Ansonsten nil
(defun ->VLA-OBJECT (ENAME /)
(cond
((= (type ENAME) 'ENAME) (vlax-ename->vla-object ENAME))
((= (type ENAME) 'VLA-OBJECT) ENAME)
(t NIL)
) ;_ end of cond
) ;_ 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
;;; Endpunkt in WKS für lineares Objekt ermitteln
(defun END-PKT? (ENAME /)
(vlax-curve-getendpoint (->VLA-OBJECT ENAME))
) ;_ end of defun
;;; Startpunkt in WKS für lineares Objekt ermitteln
(defun START-PKT? (ENAME /)
(vlax-curve-getstartpoint (->VLA-OBJECT ENAME))
) ;_ 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 (->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
;;; 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
;;; 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
(->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 (->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 (->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
(princ "\nStationierungsroutinen")
(princ "\nAufruf: STATION[2], STATION-FROM[2] oder TEST[2]")
(princ)
Foren auf CAD.de (alle Foren)
| 
- Thomas -
