Schoenenberger_Systeme_GmbH/dxfmakros
3
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of https://gitea.schoenenberger.de/Schoenenberger_Systeme_GmbH/dxfmakros

Browse Source 
# Conflicts:
#	Lisp/KreiselInsert.lsp
#	lib/export_sivas.py
This commit is contained in:
Michael Stangl
2026-07-22 11:28:30 +02:00
parent 3f916a6fed 187f0acf31
commit 048bf61ac4
140 changed files with 609185 additions and 490639 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Lisp/Gefaellestrecke.lsp
+135 -28
View File
@@ -1438,7 +1438,7 @@
startpunkt last-ent nach-aus-pt entry-hz L-first-seg
es-seite /
gf-bname gf-ss ent gf-insert typ-str anzahl-gf
gf-winkel-str i)
gf-winkel-str i gf-g10z gf-korr-dz gf-osmode-alt)
;; Beschriftung: Mitte der ersten Geraden, 400mm senkrecht versetzt
(gf-make-label gf-nummer hoehe-von hoehe-bis deltaH deltaL
L-gf-str winkel n-separator nach-aus-pt entry-hz L-first-seg)
@@ -1479,19 +1479,31 @@
(ssadd ent gf-ss)
(setq ent (entnext ent))
)
;; Block definieren und einfuegen (ATTREQ/ATTDIA=0: keine interaktive Abfrage)
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(command "_.-BLOCK" gf-bname startpunkt gf-ss "")
(command "_.INSERT" gf-bname startpunkt 1.0 1.0 0.0)
(setvar "ATTREQ" 1)
;; Block definieren und einfuegen. ssg-block-wrap-welt schaltet dabei den
;; Objektfang (OSMODE=0), die Elevation (0) und das BKS (Welt) sauber ab -
;; sonst wird der uebergebene Einfuegepunkt umgefangen bzw. der OCS-Skew der
;; gekippten Elemente schlaegt durch (Ursache des Z-Versatz-Bugs).
(ssg-block-wrap-welt gf-bname startpunkt gf-ss)
;; Attribute auf das eingefuegte INSERT-Objekt setzen (volle Werteliste;
;; nicht vorhandene Tags ignoriert ssg-attrib-set-on -> reduzierter Satz ok).
(setq gf-insert (entlast))
;; Kette wurde bei Z=0 gebaut; der OSMODE=0-Wrap loest den OCS-Skew der
;; gekippten Elemente sauber zur logischen Position (Z=0) auf. Den fertigen
;; GF_n-Block daher nur noch senkrecht auf die Zielhoehe heben (OSMODE=0,
;; sonst faengt _.MOVE die Punkte auf Objekte um). gf-g10z faengt einen
;; evtl. Rest-Z im Einfuegepunkt ab.
(setq gf-g10z (cadddr (assoc 10 (entget gf-insert))))
(setq gf-korr-dz (- hoehe-von gf-g10z))
(setq gf-osmode-alt (getvar "OSMODE"))
(setvar "OSMODE" 0)
(if (> (abs gf-korr-dz) 1e-6)
(command "_.MOVE" gf-insert "" (list 0.0 0.0 0.0) (list 0.0 0.0 gf-korr-dz)))
(setvar "OSMODE" gf-osmode-alt)
(ssg-attrib-set-on gf-insert
(list
(cons "Bezeichnung" gf-bname)
(cons "MONTAGEHOEHE_m" "0.000")
;; Montagehoehe = obere Hoehe / 1000 (mm->m); vom Benutzer editierbar
(cons "MONTAGEHOEHE_m" (rtos (/ (float hoehe-von) 1000.0) 2 3))
(cons "HOEHE_VON_mm" (itoa (fix hoehe-von)))
(cons "HOEHE_BIS_mm" (itoa (fix hoehe-bis)))
(cons "DELTA_H_mm" (itoa (fix (abs deltaH))))
@@ -1532,9 +1544,22 @@
ein-hz rad-ein xu-ein
startframe aktuell-frame
stau-endpunkt sep-endpunkt sep-frame
gf-deltaH L-gf-str nach-aus-pt gf-insert)
gf-deltaH L-gf-str nach-aus-pt gf-insert
ziel-hoehe alt-elev)
(if (null as-winkel) (setq as-winkel "90"))
(if (null es-winkel) (setq es-winkel "90"))
;; Gesamte Operation mit ELEVATION=0 fahren. Fing man den Startpunkt auf
;; einen hohen Punkt, kann ELEVATION != 0 sein und veraendert, wie die
;; gekippten Elemente gezeichnet werden (OCS-Skew wird sonst inkonsistent
;; absorbiert -> Rest-Versatz). Mit ELEVATION=0 ist der Skew immer 31.945.
(setq alt-elev (getvar "ELEVATION"))
(setvar "ELEVATION" 0.0)
;; Gepickte Zielhoehe merken und die Kette intern bei Z=0 aufbauen. Das
;; entkoppelt den (hoehenunabhaengigen) OCS-Skew der gekippten Elemente von
;; der Zielhoehe: Elemente immer bei 0 platzieren, den fertigen (nicht
;; gekippten) GF_n-Block danach in gf-block-erstellen auf ziel-hoehe heben.
(setq ziel-hoehe (caddr startpunkt))
(setq startpunkt (list (car startpunkt) (cadr startpunkt) 0.0))
(setq as-block (strcat "AS_Element_" as-winkel "_" as-seite))
(setq es-block (strcat "ES_Element_" es-winkel "_" es-seite))
(if (not *lib-initialized*) (gf-init-bibliothek))
@@ -1600,8 +1625,11 @@
(setq gf-insert
(gf-block-erstellen
"standard" as-seite gf-nummer
(caddr startpunkt)
(caddr endpunkt)
;; hoehe-von = Zielhoehe; hoehe-bis = Zielhoehe + (relative Endhoehe der
;; bei Z=0 gebauten Kette). So sind die Hoehen-Attribute korrekt, obwohl
;; die Kette intern bei 0 liegt (der GF_n-Block wird spaeter angehoben).
ziel-hoehe
(+ ziel-hoehe (caddr endpunkt))
gf-deltaH
(float deltaL-total)
L-gf-str
@@ -1615,11 +1643,13 @@
;; auf das GF_N-INSERT schreiben, damit GEFAELLESTRECKE_EDIT die Strecke
;; verlustfrei nachbauen kann. Nicht Teil des Sivas-Attributsatzes.
(gf-xdata-schreiben gf-insert hz winkel as-winkel es-winkel
(caddr startpunkt) deltaL-total)
ziel-hoehe deltaL-total)
(princ "\n\n=========================================")
(princ (ssg-text "gf-status-erfolgreich-eingefuegt"))
(princ "\n=========================================")
;; ELEVATION wiederherstellen (Nutzer-Umgebung nicht dauerhaft veraendern).
(setvar "ELEVATION" alt-elev)
;; Rueckgabe: (ename echtes-deltaH echtes-deltaL) - volle Fliesskomma-
;; Genauigkeit, unabhaengig von der auf ganze mm gerundeten HOEHE_VON/
;; HOEHE_BIS-Attribut-Darstellung im GF_N-Block.
@@ -1639,7 +1669,7 @@
;; Rueckgabe: (deltaL winkel hz-winkel as-seite es-seite einfuegehoehe
;; as-winkel es-winkel)
;; oder nil bei Abbruch / fehlendem Dialog.
(defun gf-dialog-eingabe ( prefill / dcl-pfad dat ergebnis
(defun gf-dialog-eingabe ( prefill hoehe-vorbelegung / dcl-pfad dat ergebnis
dlg-deltal dlg-hoehe dlg-winkel
dlg-richtung dlg-aus dlg-ein
dlg-aus-winkel dlg-ein-winkel
@@ -1657,8 +1687,12 @@
(set_tile "deltal"
(if prefill (rtos (cdr (assoc "deltaL" prefill)) 2 0)
(rtos (ssg-cfg-or "gefaelle" "default_delta_l" 5000.0) 2 0)))
;; Einfuegehoehe: 1) explizite Vorbelegung (gepickte Punkthoehe, Modus 1),
;; 2) prefill (Edit), 3) Default "0".
(set_tile "einfuegehoehe"
(if prefill (rtos (cdr (assoc "einfuegehoehe" prefill)) 2 1) "0"))
(cond (hoehe-vorbelegung (rtos hoehe-vorbelegung 2 1))
(prefill (rtos (cdr (assoc "einfuegehoehe" prefill)) 2 1))
(t "0")))
(set_tile "winkel"
(if prefill (rtos (cdr (assoc "winkel" prefill)) 2 1)
(rtos (ssg-cfg-or "gefaelle" "default_winkel" 3.0) 2 1)))
@@ -1721,12 +1755,18 @@
)
)
(action_tile "cancel" "(done_dialog 0)")
;; Zusatz-Button: parallelen VarioFoerderer bauen (Signal-Code 2).
;; Der VF spiegelt die BESTEHENDE GF (Werte aus XDATA), daher werden die
;; Dialog-Felder hier nicht ausgelesen.
(action_tile "build_vf" "(done_dialog 2)")
(setq ergebnis (start_dialog))
(unload_dialog dat)
(if (= ergebnis 1)
(progn
(cond
;; Signal an GEFAELLESTRECKE_EDIT: parallelen VF bauen
((= ergebnis 2) "BUILD_VF")
((= ergebnis 1)
(setq hz-winkel
(cond ((= dlg-richtung "1") 90.0)
((= dlg-richtung "2") 180.0)
@@ -1746,7 +1786,7 @@
as-winkel
es-winkel)
)
nil
(t nil)
)
)
)
@@ -1756,8 +1796,11 @@
;; Zusammenfassung, Bestaetigung und Einfuegen.
;; startpunkt: Einfuegepunkt AUS-Element (inkl. Z aus Einfuegehoehe)
;; as-winkel/es-winkel: "30" oder "90" (Element-Variante)
;; dialog-bestaetigt: T, wenn die Einfuegung bereits per Dialog-OK bestaetigt
;; wurde (Modus 1) - dann entfaellt die zusaetzliche Konsolen-Rueckfrage.
;; Modus 2 (reine Konsoleneingabe, kein Dialog) uebergibt nil/weglassen.
(defun gf-modus12-abschluss (deltaL winkel hz-winkel as-seite es-seite startpunkt
as-winkel es-winkel /
as-winkel es-winkel dialog-bestaetigt /
rad sep-x L_stau antwort)
(if (null as-winkel) (setq as-winkel "90"))
(if (null es-winkel) (setq es-winkel "90"))
@@ -1792,8 +1835,8 @@
(princ (ssg-textf "gf-status-zus2-lstau" (list (rtos L_stau 2 2))))
(princ "\n=========================================")
;; Bestaetigung
(setq antwort (getstring (ssg-text "gf-prompt-einfuegen")))
;; Bestaetigung - entfaellt, wenn bereits per Dialog-OK bestaetigt (Modus 1)
(setq antwort (if dialog-bestaetigt "1" (getstring (ssg-text "gf-prompt-einfuegen"))))
(if (not (= antwort "2"))
(gefaellestrecke-einfuegen L_stau (fix winkel) startpunkt as-seite es-seite hz-winkel deltaL as-winkel es-winkel)
(princ (ssg-text "gf-status-abgebrochen"))
@@ -1956,12 +1999,14 @@
;; Modus 1: Manuelle Eingabe via DCL-Dialog
(t
(princ (ssg-text "gf-modus1-header"))
;; Startpunkt (X/Y) in der Zeichnung waehlen; Z kommt aus dem Dialog
;; Startpunkt (X/Y/Z) in der Zeichnung waehlen. Faengt man einen Punkt mit
;; Hoehe (z.B. Basispunkt Z=12000), wird diese als Einfuegehoehe in den
;; Dialog vorbelegt - der Nutzer kann sie dort bestaetigen oder aendern.
(setq startpunkt-fuer-einfuegen
(getpoint (ssg-text "gf-prompt-startpunkt-aus")))
(if (null startpunkt-fuer-einfuegen)
(setq startpunkt-fuer-einfuegen '(0 0 0)))
(setq dlg-werte (gf-dialog-eingabe nil))
(setq dlg-werte (gf-dialog-eingabe nil (caddr startpunkt-fuer-einfuegen)))
(if (null dlg-werte)
(princ (ssg-text "gf-status-abgebrochen"))
(progn
@@ -1972,7 +2017,11 @@
es-seite (nth 4 dlg-werte)
gf-as-winkel (nth 6 dlg-werte)
gf-es-winkel (nth 7 dlg-werte))
;; Einfuegehoehe (Z) aus Dialog auf gewaehlten Startpunkt anwenden
;; Einfuegehoehe = Dialogwert (nth 5), der mit der gepickten Hoehe
;; vorbelegt wurde. So gewinnt die gepickte Hoehe standardmaessig,
;; bleibt aber im Dialog editierbar. Nur diese Z-Hoehe zaehlt (X/Y
;; vom gefangenen Punkt) -> geht als ziel-hoehe in die Attribute und
;; als finale Hoehe in den GF_n-Move (gf-block-erstellen).
(setq startpunkt-fuer-einfuegen
(list (car startpunkt-fuer-einfuegen)
(cadr startpunkt-fuer-einfuegen)
@@ -1981,8 +2030,9 @@
(setq deltaL (ssg-cfg-or "gefaelle" "default_delta_l" 5000.0)))
(if (or (null winkel) (<= winkel 0))
(setq winkel (ssg-cfg-or "gefaelle" "default_winkel" 3.0)))
;; Dialog-OK wurde bereits bestaetigt - keine zusaetzliche Rueckfrage
(gf-modus12-abschluss deltaL winkel hz-winkel as-seite es-seite
startpunkt-fuer-einfuegen gf-as-winkel gf-es-winkel)
startpunkt-fuer-einfuegen gf-as-winkel gf-es-winkel T)
)
)
)
@@ -1999,9 +2049,56 @@
;; zeigt sie vorbelegt im Dialog und baut die Strecke bei OK am selben
;; Startpunkt neu auf. Wird vom Doppelklick-Dispatcher SSG_BLOCKEDIT
;; fuer Blocknamen "GF_*" aufgerufen.
;; ============================================================
;; Parallelen Standard-VarioFoerderer neben eine bestehende Gefaellestrecke
;; bauen: gegenlaeufig (hz+180), steigend ("Auf"), 2000 mm seitlich versetzt,
;; gleiche DeltaL/DeltaH. Die GF bleibt unveraendert. Winkel + GF-Aufteilung
;; werden ueber den Standard-VF-Dialog abgefragt.
;;
;; Versatz-Seite haengt von der GF-AS-Seite ab:
;; GF-AS rechts -> VF links (hz+90), GF-AS links -> VF rechts (hz-90).
;;
;; gf-start: GF-Startpunkt (X Y Z), Z = obere Hoehe (HOEHE_VON)
;; hz: GF-Fahrtrichtung in Grad
;; deltaL: planare Gesamtlaenge der GF (= VF-DeltaL)
;; as-seite: GF-AS-Seite ("rechts"/"links")
;; hoehe-bis: untere GF-Hoehe (HOEHE_BIS) = VF-Einfuegehoehe (Kettenanfang)
;; ============================================================
(defun gf-baue-parallel-vf (gf-start hz deltaL as-seite hoehe-bis /
abstand rad hz-vf deltaH gf-end-x gf-end-y
perp-x perp-y vf-start vf-seite)
(if (null (car (atoms-family 1 '("VFS-STANDARD-DIALOG-BERECHNEN-EINFUEGEN"))))
(alert (ssg-text "gf-vf-modul-fehlt"))
(progn
(setq abstand 2000.0)
(setq rad (* hz (/ pi 180.0)))
(setq deltaH (- (caddr gf-start) hoehe-bis)) ; HOEHE_VON - HOEHE_BIS
;; GF-Endpunkt (X/Y) = GF-Start + deltaL entlang hz
(setq gf-end-x (+ (car gf-start) (* deltaL (cos rad)))
gf-end-y (+ (cadr gf-start) (* deltaL (sin rad))))
;; Versatz senkrecht zur Fahrtrichtung: VF auf DIESELBE benannte Seite wie
;; das GF-AS-Element (GF-AS links -> VF links der Fahrtrichtung; GF-AS
;; rechts -> VF rechts). links = (hz+90) = (-sin, cos); rechts = (sin, -cos).
(if (= as-seite "rechts")
(setq perp-x (sin rad) perp-y (- (cos rad))) ; rechts der Fahrtrichtung
(setq perp-x (- (sin rad)) perp-y (cos rad))) ; links der Fahrtrichtung
;; VF-Startpunkt = GF-Endpunkt + Versatz, Z = unteres GF-Ende (HOEHE_BIS).
;; Der VF baut "Auf" und erreicht am Ende wieder HOEHE_VON.
(setq vf-start (list (+ gf-end-x (* abstand perp-x))
(+ gf-end-y (* abstand perp-y))
hoehe-bis))
(setq hz-vf (rem (+ hz 180.0) 360.0))
(setq vf-seite as-seite) ; VF-AS/ES-Seite: Default = GF-AS-Seite
(vfs-standard-dialog-berechnen-einfuegen
(vf-next-number) deltaL deltaH "Auf" vf-start hz-vf vf-seite nil)
(princ (ssg-text "gf-vf-gebaut"))
)
)
)
(defun c:GEFAELLESTRECKE_EDIT ( / ss ent ed bname startpunkt attribs xd
hz winkel as-winkel es-winkel z-start deltaL
prefill dlg-werte)
as-seite hoehe-bis prefill dlg-werte)
;; Implied Selection VOR ssg-start pruefen (ssg-start hebt Selektion auf)
(setq ss (ssget "I"))
(if (and ss (= (sslength ss) 1)
@@ -2070,10 +2167,20 @@
(cons "as-winkel" as-winkel)
(cons "es-winkel" es-winkel)))
;; AS-Seite + untere Hoehe fuer den optionalen parallelen VF-Bau
(setq as-seite (cond ((cdr (assoc "SEITE_AS" attribs))) ("links")))
(setq hoehe-bis (atof (cond ((cdr (assoc "HOEHE_BIS_mm" attribs))) ("0"))))
(setq dlg-werte (gf-dialog-eingabe prefill))
(if (null dlg-werte)
(princ (ssg-text "gf-status-abgebrochen"))
(progn
(cond
((null dlg-werte)
(princ (ssg-text "gf-status-abgebrochen")))
;; Zusatz-Button: parallelen VarioFoerderer bauen, GF bleibt unveraendert.
((equal dlg-werte "BUILD_VF")
(gf-baue-parallel-vf
(list (car startpunkt) (cadr startpunkt) z-start)
hz deltaL as-seite hoehe-bis))
(t
;; Alten GF-Verbund loeschen und am selben Startpunkt (X/Y) mit der
;; im Dialog gewaehlten Einfuegehoehe (Z) neu aufbauen.
(entdel ent)
Lisp/KreiselInsert.lsp
+20 -9
View File
@@ -71,19 +71,25 @@
(setq *kreisel-default-hoehe* (ssg-cfg-or "kreisel" "default_hoehe" 2000.0))
;; Attribut-Definitionen: ((TAG DEFAULT) ...)
;; Anzeige-/Attributreihenfolge im Block (ID zuerst, dann Bezeichnung,
;; Artinr. fest 6200, Montage-/Hoehendaten, dann Ausstattung).
;; NUMMER steht am Ende (wird intern fuer Nummerierung/Blockname
;; benoetigt; Entfernen erfordert Refactor der Nummernvergabe).
(setq *kreisel-attrib-defs*
'(("Bezeichnung" "")
("DREHRICHTUNG" "UZS")
("ANZAHL_SEPARATOR" "2")
'(("ID" "")
("Bezeichnung" "")
("Artinr." "6200")
("MONTAGEHOEHE_m" "0.000")
("HOEHE" "0")
("KREISELART" "STANDARD")
("ABSTAND" "2300")
("ANZAHL_SEPARATOR" "2")
("ANZAHL_SCANNER" "0")
("N_RAMPEN" "0")
("DREHUNG" "0")
("ABSTAND" "2300")
("NUMMER" "0")
("HOEHE" "0")
("ANZAHL_RAMPEN" "0")
("GERUEST_EINZELMODUL" "0")
("ID" ""))
("DREHRICHTUNG" "UZS")
("DREHUNG" "0")
("NUMMER" "0"))
)
;; Eckrad-Einstellungen
@@ -354,6 +360,11 @@
(setq attribs (subst (cons "HOEHE" block-hoehe)
(assoc "HOEHE" attribs) attribs))
;; Montagehoehe in Metern ableiten (Default = HOEHE / 1000, mm->m).
;; Bleibt ein normales Attribut und kann vom Benutzer geaendert werden.
(setq attribs (subst (cons "MONTAGEHOEHE_m" (rtos (/ z-hoehe 1000.0) 2 3))
(assoc "MONTAGEHOEHE_m" attribs) attribs))
;; Abgeleitete Masse
(setq radius (/ *kreisel-durchmesser* 2.0))
(setq pin-y (- radius *kreisel-pin-abstand*))
Lisp/OmniModulInsert.lsp
+149 -93
View File
@@ -332,12 +332,13 @@
;; z.B. "APB 60" oder "APB 110" (nil = keine Einschraenkung)
;; Rueckgabe: (eintrag hoehe drehung) oder nil bei Abbruch
(defun omni:bogen-dialog (winkel init-hoehe init-drehung profiltyp / dcl-pfad dat boegen-liste
profil-liste ergebnis dlg-hoehe dlg-drehung profil)
profil-liste ergebnis dlg-hoehe profil)
(if (null *OMNI-BOEGEN*) (omni:load-data))
;; Defaults
;; Hinweis: init-drehung wird nicht mehr verwendet - die Drehung wird nach
;; dem Einfuegen interaktiv abgefragt (omni:insert-dxf mit drehung=nil).
(if (null init-hoehe) (setq init-hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(if (null init-drehung) (setq init-drehung (ssg-cfg-or "omniflo" "default_drehung" "0")))
;; Boegen nach Winkel filtern
(setq boegen-liste (omni:filter *OMNI-BOEGEN* "KurvenWinkel" winkel))
@@ -388,9 +389,8 @@
(end_list)
(set_tile "bogenart" "0")
;; Hoehe und Drehung initialisieren
;; Hoehe initialisieren (Drehung erfolgt interaktiv nach dem Einfuegen)
(set_tile "val_hoehe" init-hoehe)
(set_tile "val_drehung" init-drehung)
;; Startwerte anzeigen
(omni:bogen-dlg-update "0")
@@ -403,16 +403,15 @@
(strcat
"(setq ergebnis (atoi (get_tile \"bogenart\")))"
"(setq dlg-hoehe (get_tile \"val_hoehe\"))"
"(setq dlg-drehung (get_tile \"val_drehung\"))"
"(done_dialog 1)"))
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog dat)
;; Gewaehlten Eintrag mit Hoehe/Drehung zurueckgeben
;; Gewaehlten Eintrag mit Hoehe zurueckgeben (drehung=nil -> interaktiv)
(if ergebnis
(list (nth ergebnis *OMNI-DLG-BOEGEN*) dlg-hoehe dlg-drehung)
(list (nth ergebnis *OMNI-DLG-BOEGEN*) dlg-hoehe nil)
nil
)
)
@@ -589,6 +588,10 @@
(if (tblsearch "BLOCK" bname)
(setq bname (strcat bname "_" (itoa (fix (* (getvar "CDATE") 1000000)))))
)
;; Objektfang aus: sonst kann _.INSERT den Einfuegepunkt pt
;; auf ein Objekt umfangen (z.B. den Text bei pt) und die
;; Hoehe verfaelschen. OSMODE via ssg-start gesichert.
(setvar "OSMODE" 0)
(command "_.-BLOCK" bname (list 0.0 0.0 0.0) ss "")
;; Block einfuegen (ATTREQ/ATTDIA bereits auf 0)
@@ -762,13 +765,14 @@
;; weichentyp = "Einzelweiche", "Doppelweiche", "Dreiwegeweiche" oder nil fuer alle
;; init-hoehe / init-drehung = Vorbelegung (optional, fuer Edit-Modus)
;; Rueckgabe: (eintrag hoehe drehung) oder nil bei Abbruch
(defun omni:weichen-dialog (winkel weichentyp init-hoehe init-drehung / dcl-pfad dat basis-liste
profil-liste ergebnis dlg-hoehe dlg-drehung)
(defun omni:weichen-dialog (winkel weichentyp init-hoehe init-drehung breite / dcl-pfad dat basis-liste
profil-liste ergebnis dlg-hoehe)
(if (null *OMNI-WEICHEN*) (omni:load-data))
;; Defaults
;; Hinweis: init-drehung wird nicht mehr verwendet - die Drehung wird nach
;; dem Einfuegen interaktiv abgefragt (omni:insert-dxf mit drehung=nil).
(if (null init-hoehe) (setq init-hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(if (null init-drehung) (setq init-drehung (ssg-cfg-or "omniflo" "default_drehung" "0")))
;; Weichen nach Winkel filtern (nil = alle Winkel)
(if winkel
@@ -784,6 +788,14 @@
basis-liste))
)
;; Optional nach Breite filtern (z.B. Weichenkombinationen Delta 1400/700 vs. 1600/800)
(if breite
(setq basis-liste
(vl-remove-if-not
'(lambda (e) (= (cdr (assoc "Breite" e)) breite))
basis-liste))
)
(if (null basis-liste)
(progn
(alert (ssg-textf "omni-weiche-keine-gefunden"
@@ -819,9 +831,8 @@
(end_list)
(set_tile "profiltyp" "0")
;; Hoehe und Drehung initialisieren
;; Hoehe initialisieren (Drehung erfolgt interaktiv nach dem Einfuegen)
(set_tile "val_hoehe" init-hoehe)
(set_tile "val_drehung" init-drehung)
;; Startwerte anzeigen
(omni:weichen-dlg-update "0")
@@ -842,16 +853,15 @@
(strcat
"(setq ergebnis (atoi (get_tile \"profiltyp\")))"
"(setq dlg-hoehe (get_tile \"val_hoehe\"))"
"(setq dlg-drehung (get_tile \"val_drehung\"))"
"(done_dialog 1)"))
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog dat)
;; Gewaehlten Eintrag mit Hoehe/Drehung zurueckgeben
;; Gewaehlten Eintrag mit Hoehe zurueckgeben (drehung=nil -> interaktiv)
(if ergebnis
(list (nth ergebnis *OMNI-DLG-WEICHEN*) dlg-hoehe dlg-drehung)
(list (nth ergebnis *OMNI-DLG-WEICHEN*) dlg-hoehe nil)
nil
)
)
@@ -872,7 +882,8 @@
;; hoehe = Hoehe in mm als String (wird als HOEHE-Attribut gesetzt)
;; drehung = Drehwinkel in Grad als String (Block-Rotation)
;; Rueckgabe: Einfuegepunkt oder nil bei Abbruch
(defun omni:insert-dxf (sivasnr-str hoehe drehung / dxf-pfad omniflo-pfad pt angleDeg winkel-rad drehung-anzeige blockEnt attribs layer-name)
(defun omni:insert-dxf (sivasnr-str hoehe drehung / dxf-pfad omniflo-pfad angleDeg
drehung-anzeige blockEnt attribs layer-name ed pt10 zval zdelta)
(setq omniflo-pfad (getenv "DXFM_OMNIFLO"))
(if (null omniflo-pfad)
(progn
@@ -887,76 +898,94 @@
nil
)
(progn
(setq pt (getpoint (ssg-text "omni-prompt-einfuegepunkt")))
(if (null pt)
(progn (princ (ssg-text "omni-abbruch-omni")) nil)
(progn
(ssg-start "OMNI DXF Insert" '(("OSMODE") ("ATTREQ") ("ATTDIA")))
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(ssg-start "OMNI DXF Insert" '(("ATTREQ") ("ATTDIA")))
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
;; Drehwinkel aus Dialog uebernehmen, sonst interaktiv am Einfuegepunkt abfragen
(if drehung
;; Absolute Z-Hoehe fuer den Einfuegepunkt bestimmen
(setq zval (if (and hoehe (/= hoehe "")) (atof hoehe) 0.0))
;; Interaktives Einfuegen mit Live-Vorschau am Mauszeiger:
;; dxf-pfad -> Block aus Datei definieren/waehlen
;; 1. 'pause -> Einfuegepunkt; Objekt haengt sichtbar am Cursor und
;; verschiebt sich mit der Maus (erster Klick positioniert)
;; "" "" -> X-/Y-Massstab = 1
;; Drehung -> aus Dialog fest, sonst 2. 'pause: Objekt dreht sich
;; beim Ziehen sichtbar mit, zweiter Klick beendet
(if drehung
(progn
(setq angleDeg (atof drehung))
(setq drehung-anzeige drehung)
(command "_.INSERT" dxf-pfad pause "" "" angleDeg)
)
(command "_.INSERT" dxf-pfad pause "" "" pause)
)
;; INSERT vollstaendig abschliessen (bei Bedarf weitere Eingabe zulassen)
(while (> (getvar "CMDACTIVE") 0) (command pause))
(setq blockEnt (entlast))
(if (and blockEnt (= (cdr (assoc 0 (entget blockEnt))) "INSERT"))
(progn
(setq ed (entget blockEnt))
;; Tatsaechlich per Maus gesetzte Drehung ermitteln (interaktiv)
(if (null drehung)
(progn
(setq angleDeg (atof drehung))
(setq drehung-anzeige drehung)
)
(progn
(setq winkel-rad (getangle pt (ssg-text "omni-prompt-drehwinkel")))
(setq angleDeg (if winkel-rad (* winkel-rad (/ 180.0 pi)) 0.0))
(setq angleDeg (* (cdr (assoc 50 ed)) (/ 180.0 pi)))
(setq drehung-anzeige (rtos angleDeg 2 1))
)
)
;; Hoehe als Z-Koordinate auf den Einfuegepunkt anwenden
(if (and hoehe (/= hoehe ""))
(setq pt (list (car pt) (cadr pt) (atof hoehe)))
(setq pt (list (car pt) (cadr pt) (if (caddr pt) (caddr pt) 0.0)))
;; Z-Hoehe absolut anwenden: Block (inkl. Attribute) per MOVE um
;; die Differenz zum aktuellen Einfuegepunkt-Z verschieben. Osnap
;; beim interaktiven Einfuegen kann eine abweichende Z-Lage liefern,
;; daher Differenz statt fixem Wert (vgl. GF-Z-Versatz-Bug).
;; Explizite Koordinaten unterliegen keinem Objektfang.
(setq pt10 (cdr (assoc 10 ed)))
(setq zdelta (- zval (caddr pt10)))
(if (/= zdelta 0.0)
(command "_.MOVE" blockEnt "" (list 0.0 0.0 0.0) (list 0.0 0.0 zdelta))
)
;; Block einfuegen mit Drehwinkel aus Dialog
(command "_.INSERT" dxf-pfad pt "" "" angleDeg)
;; INSERT vollstaendig abschliessen (Attribut-Prompts beenden)
(while (> (getvar "CMDACTIVE") 0) (command ""))
;; HOEHE und DREHUNG Attribute setzen
(ssg-attrib-set-on blockEnt
(list (cons "HOEHE" (if hoehe hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(cons "DREHUNG" drehung-anzeige)))
(setq blockEnt (entlast))
(if (and blockEnt (= (cdr (assoc 0 (entget blockEnt))) "INSERT"))
;; Layer aus LAYER-Attribut lesen und Block verschieben
(setq attribs (ssg-attrib-read blockEnt))
(setq layer-name (cdr (assoc "LAYER" attribs)))
(if (and layer-name (> (strlen layer-name) 0))
(progn
;; HOEHE und DREHUNG Attribute setzen
(ssg-attrib-set-on blockEnt
(list (cons "HOEHE" (if hoehe hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(cons "DREHUNG" drehung-anzeige)))
;; Layer aus LAYER-Attribut lesen und Block verschieben
(setq attribs (ssg-attrib-read blockEnt))
(setq layer-name (cdr (assoc "LAYER" attribs)))
(if (and layer-name (> (strlen layer-name) 0))
(progn
(ssg-make-layer layer-name 7 nil)
(entmod (subst (cons 8 layer-name) (assoc 8 (entget blockEnt)) (entget blockEnt)))
(entupd blockEnt)
)
)
(ssg-make-layer layer-name 7 nil)
(entmod (subst (cons 8 layer-name) (assoc 8 (entget blockEnt)) (entget blockEnt)))
(entupd blockEnt)
)
)
;; Eindeutige ID zuweisen
(if (and blockEnt (atoms-family 1 '("ssg-id-generate")))
(ssg-id-generate blockEnt)
)
(princ (ssg-textf "omni-dxf-eingefuegt"
(list
sivasnr-str
(if hoehe hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000"))
drehung-anzeige
(if layer-name (strcat " Layer=" layer-name) "")
)))
(ssg-end)
pt
)
)
;; Fallback fuer Anzeige, falls keine Drehung ermittelt wurde
(if (null drehung-anzeige)
(setq drehung-anzeige (rtos (if angleDeg angleDeg 0.0) 2 1))
)
;; Eindeutige ID zuweisen
(if (and blockEnt (atoms-family 1 '("ssg-id-generate")))
(ssg-id-generate blockEnt)
)
(princ (ssg-textf "omni-dxf-eingefuegt"
(list
sivasnr-str
(if hoehe hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000"))
drehung-anzeige
(if layer-name (strcat " Layer=" layer-name) "")
)))
(ssg-end)
;; Rueckgabe: tatsaechlicher Einfuegepunkt
(if blockEnt (cdr (assoc 10 (entget blockEnt))))
)
)
)
@@ -987,7 +1016,7 @@
;; --- Omniflo / Weiche 90 Grad ---
(defun c:OMNI_W90_Einfach ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 90 "Einzelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 90 "Einzelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -996,7 +1025,7 @@
)
(defun c:OMNI_W90_Doppel ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 90 "Doppelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 90 "Doppelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1005,7 +1034,7 @@
)
(defun c:OMNI_W90_Dreiwege ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 90 "Dreiwegeweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 90 "Dreiwegeweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1015,7 +1044,7 @@
;; --- Omniflo / Weiche 45 Grad ---
(defun c:OMNI_W45_Einfach ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 45 "Einzelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 45 "Einzelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1024,7 +1053,7 @@
)
(defun c:OMNI_W45_Doppel ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 45 "Doppelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 45 "Doppelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1033,7 +1062,7 @@
)
(defun c:OMNI_W45_Dreiwege ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 45 "Dreiwegeweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 45 "Dreiwegeweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1043,7 +1072,7 @@
;; --- Omniflo / Weichen Parallel ---
(defun c:OMNI_WP_Einfach ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 0 "Einzelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 0 "Einzelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1052,7 +1081,7 @@
)
(defun c:OMNI_WP_Doppel ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 0 "Doppelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 0 "Doppelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1061,7 +1090,7 @@
)
(defun c:OMNI_WP_Dreiwege ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 0 "Dreiwegeweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 0 "Dreiwegeweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1071,7 +1100,7 @@
;; --- Omniflo / Weichenkoerper ---
(defun c:OMNI_WK_Einfach ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 22.5 "Einzelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 22.5 "Einzelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1080,7 +1109,7 @@
)
(defun c:OMNI_WK_Doppel ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 22.5 "Doppelweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 22.5 "Doppelweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1089,7 +1118,7 @@
)
(defun c:OMNI_WK_Dreiwege ( / dlg-result)
(setq dlg-result (omni:weichen-dialog 22.5 "Dreiwegeweiche" nil nil))
(setq dlg-result (omni:weichen-dialog 22.5 "Dreiwegeweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1098,8 +1127,17 @@
)
;; --- Omniflo / Weichenkombinationen ---
(defun c:OMNI_WKomb_Delta ( / dlg-result)
(setq dlg-result (omni:weichen-dialog nil "Deltaweiche" nil nil))
(defun c:OMNI_WKomb_Delta_1400 ( / dlg-result)
(setq dlg-result (omni:weichen-dialog nil "Deltaweiche" nil nil 1400))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
)
(princ)
)
(defun c:OMNI_WKomb_Delta_1600 ( / dlg-result)
(setq dlg-result (omni:weichen-dialog nil "Deltaweiche" nil nil 1600))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1108,7 +1146,7 @@
)
(defun c:OMNI_WKomb_Star ( / dlg-result)
(setq dlg-result (omni:weichen-dialog nil "Sternweiche" nil nil))
(setq dlg-result (omni:weichen-dialog nil "Sternweiche" nil nil nil))
(if dlg-result
(omni:insert-from-entry dlg-result)
(princ (ssg-text "omni-abbruch-weiche"))
@@ -1126,7 +1164,8 @@
artinr hoehe drehung rotation
typ eintrag winkel weichentyp
dlg-result new-eintrag new-hoehe new-drehung
basePoint sivasnr-str dxf-pfad data-pfad angleDeg blockEnt)
basePoint sivasnr-str dxf-pfad data-pfad angleDeg blockEnt
layer-name)
;; Implied Selection pruefen
(setq ss (ssget "I"))
@@ -1221,7 +1260,7 @@
(progn
(setq winkel (cdr (assoc "KurvenWinkel" eintrag)))
(setq weichentyp (cdr (assoc "WeichenTyp" eintrag)))
(setq dlg-result (omni:weichen-dialog winkel weichentyp hoehe drehung))
(setq dlg-result (omni:weichen-dialog winkel weichentyp hoehe drehung nil))
)
)
@@ -1230,9 +1269,13 @@
)
;; 5. Neuen Eintrag und Werte extrahieren
;; Drehung: Dialog liefert keine Drehung mehr (interaktiv beim Neu-Einfuegen);
;; beim Edit wird die bestehende Blockdrehung beibehalten. Quelle ist die
;; tatsaechliche Geometrie (rotation = Gruppe 50 in Grad, immer numerisch),
;; nicht das DREHUNG-Attribut (kann fehlen/kein Zahl-String sein -> (atof T)).
(setq new-eintrag (car dlg-result))
(setq new-hoehe (cadr dlg-result))
(setq new-drehung (caddr dlg-result))
(setq new-drehung (rtos rotation 2 1))
(setq sivasnr-str (omni:sivasid-to-str (omni:val new-eintrag "Sivasnr")))
;; 6. DXF-Datei pruefen
@@ -1263,9 +1306,22 @@
;; Attribute setzen
(if (and blockEnt (= (cdr (assoc 0 (entget blockEnt))) "INSERT"))
(ssg-attrib-set-on blockEnt
(list (cons "HOEHE" (if new-hoehe new-hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(cons "DREHUNG" (if new-drehung new-drehung (ssg-cfg-or "omniflo" "default_drehung" "0")))))
(progn
(ssg-attrib-set-on blockEnt
(list (cons "HOEHE" (if new-hoehe new-hoehe (ssg-cfg-or "omniflo" "default_hoehe" "2000")))
(cons "DREHUNG" (if new-drehung new-drehung (ssg-cfg-or "omniflo" "default_drehung" "0")))))
;; Layer aus LAYER-Attribut lesen und Block verschieben (wie omni:insert-dxf)
(setq attribs (ssg-attrib-read blockEnt))
(setq layer-name (cdr (assoc "LAYER" attribs)))
(if (and layer-name (> (strlen layer-name) 0))
(progn
(ssg-make-layer layer-name 7 nil)
(entmod (subst (cons 8 layer-name) (assoc 8 (entget blockEnt)) (entget blockEnt)))
(entupd blockEnt)
)
)
)
)
(princ (ssg-textf "omni-edit-aktualisiert"
Lisp/TEFInsert.lsp
-6
View File
@@ -169,12 +169,6 @@
(setq hz (* (atan dy dx) (/ 180.0 pi)))
(setq winkel (* (atan (- dz) horiz) (/ 180.0 pi)))
;; Linie zwischen den beiden Punkten zeichnen
(entmake (list '(0 . "LINE")
(cons 8 (getvar "CLAYER"))
(cons 10 p1)
(cons 11 p2)))
;; Volle Elemente ab dem Startpunkt aneinanderreihen
(setq anzahl-voll
(fix (/ (+ laenge *tefl-toleranz*) *tefl-elementlaenge*)))
Lisp/check_hoehen.lsp
+452
View File
@@ -0,0 +1,452 @@
;;; ============================================================
;;; check_hoehen.lsp - Hoehen-Check (PHASE 1-3)
;;; ------------------------------------------------------------
;;; Phase 1 - messen & schreiben:
;;; Kreisel : Z des Einfuegepunkts -> HOEHE
;;; VF/GF : KS_EIN.Z (aus AS_Element) -> HOEHE_VON_mm
;;; KS_AUS.Z (aus ES_Element) -> HOEHE_BIS_mm
;;; MONTAGEHOEHE_m:
;;; Kreisel = HOEHE / 1000
;;; Gefaellestrecke = HOEHE_VON_mm / 1000
;;; VarioFoerderer = (HOEHE_VON_mm + HOEHE_BIS_mm) / 2 / 1000
;;;
;;; Phase 2 - 0-/Negativ-Pruefung (ungueltig = Wert <= 0 oder nicht
;;; messbar):
;;; - Hoehe eingeben -> Block in Z verschieben, Attribute neu.
;;; - ENTER -> Markierungskreis (Layer *ch-mark-layer*),
;;; Block spaeter manuell anpassen.
;;;
;;; Phase 3 - Buehne: liegt die rohe Montagehoehe ueber
;;; *ch-buehne-schwelle-m* (Default 2,0 m), wird pro Block gefragt,
;;; ob eine Buehne vorhanden ist; deren Hoehe wird abgezogen
;;; (MONTAGEHOEHE_m = roh - Buehne).
;;;
;;; PHASE 1-3 bewusst OHNE: QSAVE (Testmodus, UNDO moeglich).
;;;
;;; Aufruf: HOEHEN_CHECK
;;; Nutzt die KS-Extraktion aus vf_core (extract-ks-from-block-raw).
;;; ============================================================
(vl-load-com)
;; Blockname-Muster (Grossschreibung) der KS-tragenden Teilbloecke.
(setq *ch-as-pattern* "AS_ELEMENT*") ;; enthaelt KS_EIN (Hoehe von)
(setq *ch-es-pattern* "ES_ELEMENT*") ;; enthaelt KS_AUS (Hoehe bis)
;; Markierung ungueltiger Hoehen: Kreis auf eigenem Layer.
(setq *ch-mark-layer* "S_HOEHE_PRUEFEN")
(setq *ch-mark-color* 1) ;; 1 = Rot
(if (null *ch-mark-radius-factor*) (setq *ch-mark-radius-factor* 1.1))
(if (null *ch-mark-radius-min*) (setq *ch-mark-radius-min* 1000.0))
;; Schwelle (m): ab dieser Montagehoehe wird pro Block nach einer
;; Buehne gefragt (typische Anlagenhoehe ~2 m; darueber liegt die
;; Anlage vermutlich auf einer Buehne).
(if (null *ch-buehne-schwelle-m*) (setq *ch-buehne-schwelle-m* 2.0))
;;; ------------------------------------------------------------
;;; vf_core-KS-Helfer sicherstellen (extract-ks-from-block-raw).
;;; ------------------------------------------------------------
(defun ch-ensure-vfcore ( / p)
(if (null (car (atoms-family 1 '("EXTRACT-KS-FROM-BLOCK-RAW"))))
(cond
((car (atoms-family 1 '("SSG-ENSURE")))
(vl-catch-all-apply '(lambda () (ssg-ensure "VarioFoerderer"))))
((getenv "DXFM_LISP")
(setq p (strcat (vl-string-translate "\\" "/" (getenv "DXFM_LISP")) "/vf_core.lsp"))
(if (findfile p) (vl-catch-all-apply 'load (list p))))
)
)
(if (car (atoms-family 1 '("EXTRACT-KS-FROM-BLOCK-RAW"))) t nil)
)
;;; ------------------------------------------------------------
;;; Attributwert an einem INSERT setzen (Tag ohne Gross/Klein).
;;; Nur wenn der Block Attribute fuehrt (66=1). Rueckgabe: T/nil.
;;; ------------------------------------------------------------
(defun ch-set-att (ins tag val / e ed done ok)
(setq done nil ok nil)
(if (= (cdr (assoc 66 (entget ins))) 1)
(progn
(setq e (entnext ins))
(while (and e (not done))
(setq ed (entget e))
(cond
((= (cdr (assoc 0 ed)) "ATTRIB")
(if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
(progn
(entmod (subst (cons 1 val) (assoc 1 ed) ed))
(entupd e)
(setq ok t))))
((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
)
(setq e (entnext e))
)
)
)
ok
)
;;; ------------------------------------------------------------
;;; Attributwert (String) an einem INSERT lesen. "" wenn fehlend.
;;; ------------------------------------------------------------
(defun ch-get-att-str (ins tag / e ed done val)
(setq done nil val "")
(if (= (cdr (assoc 66 (entget ins))) 1)
(progn
(setq e (entnext ins))
(while (and e (not done))
(setq ed (entget e))
(cond
((= (cdr (assoc 0 ed)) "ATTRIB")
(if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
(progn (setq val (cdr (assoc 1 ed))) (setq done t))))
((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
)
(setq e (entnext e))
)
)
)
val
)
;;; ------------------------------------------------------------
;;; Sortier-Vergleich fuer Kandidaten (idnum ename idx).
;;; Primaer nach ID-Nummer, sekundaer nach Fund-Index (verhindert,
;;; dass vl-sort Eintraege mit gleicher ID verwirft).
;;; ------------------------------------------------------------
(defun ch-id< (a b)
(if (= (car a) (car b)) (< (caddr a) (caddr b)) (< (car a) (car b)))
)
;;; ------------------------------------------------------------
;;; Z-Koordinate des KS-Ursprungs aus einem ks-data-Satz holen.
;;; ------------------------------------------------------------
(defun ch-ks-z (ksdata ksname / entry)
(setq entry (cadr (assoc ksname ksdata)))
(if entry (caddr (car entry)) nil)
)
;;; ------------------------------------------------------------
;;; KS_EIN.Z / KS_AUS.Z eines Composite-Blocks (VF_n/GF_n) messen.
;;; Rueckgabe: (kez kaz) - fehlende Werte = nil.
;;; ------------------------------------------------------------
(defun ch-measure-vfgf (ename / obj subs nm ksdata kez kaz)
(setq kez nil kaz nil)
(setq obj (vlax-ename->vla-object ename))
(setq subs (vl-catch-all-apply 'vlax-invoke (list obj 'Explode)))
(if (and (not (vl-catch-all-error-p subs)) subs)
(progn
(foreach sub subs
(if (and (not (vlax-erased-p sub))
(= (vla-get-ObjectName sub) "AcDbBlockReference"))
(progn
(setq nm (strcase (vla-get-Name sub)))
(cond
((and (null kez) (wcmatch nm *ch-as-pattern*))
(setq ksdata (extract-ks-from-block-raw sub))
(setq kez (ch-ks-z ksdata "KS_EIN")))
((and (null kaz) (wcmatch nm *ch-es-pattern*))
(setq ksdata (extract-ks-from-block-raw sub))
(setq kaz (ch-ks-z ksdata "KS_AUS")))
)
)
)
)
(foreach sub subs
(if (not (vlax-erased-p sub))
(vl-catch-all-apply 'vla-Delete (list sub))))
)
)
(list kez kaz)
)
;;; ------------------------------------------------------------
;;; getboundingbox-Punkt (Safearray/Variant) in Liste wandeln.
;;; ------------------------------------------------------------
(defun ch-pt->list (v)
(cond
((= (type v) 'variant) (vlax-safearray->list (vlax-variant-value v)))
((= (type v) 'safearray) (vlax-safearray->list v))
((listp v) v)
(t nil)
)
)
;;; ------------------------------------------------------------
;;; Bounding-Box (WCS, XY) eines INSERT: (minx miny maxx maxy) oder nil.
;;; ------------------------------------------------------------
(defun ch-bbox (ent / obj res)
(setq obj (vlax-ename->vla-object ent))
(vl-catch-all-apply 'vla-update (list obj))
(setq res
(vl-catch-all-apply
'(lambda ( / ll ur)
(vla-getboundingbox obj 'll 'ur)
(list (ch-pt->list ll) (ch-pt->list ur)))))
(if (vl-catch-all-error-p res)
nil
(list (car (car res)) (cadr (car res)) (car (cadr res)) (cadr (cadr res)))
)
)
;;; ------------------------------------------------------------
;;; Layer anlegen / Farbe angleichen (ohne aktuellen Layer zu aendern).
;;; ------------------------------------------------------------
(defun ch-ensure-layer (name color / lay ed)
(if (tblsearch "LAYER" name)
(progn
(setq lay (tblobjname "LAYER" name) ed (entget lay))
(if (assoc 62 ed)
(entmod (subst (cons 62 color) (assoc 62 ed) ed))))
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 name) (cons 70 0) (cons 62 color) (cons 6 "Continuous")))
)
)
;;; ------------------------------------------------------------
;;; Block mit einem Kreis markieren (zentriert, Radius aus XY-Box).
;;; ------------------------------------------------------------
(defun ch-mark (ent / bb ipt cx cy cz r)
(setq bb (ch-bbox ent))
(setq ipt (cdr (assoc 10 (entget ent))))
(setq cz (if (and ipt (caddr ipt)) (caddr ipt) 0.0))
(if bb
(progn
(setq cx (/ (+ (nth 0 bb) (nth 2 bb)) 2.0)
cy (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
(setq r (* *ch-mark-radius-factor*
(/ (distance (list (nth 0 bb) (nth 1 bb))
(list (nth 2 bb) (nth 3 bb))) 2.0)))
(if (< r *ch-mark-radius-min*) (setq r *ch-mark-radius-min*)))
(progn (setq cx (car ipt) cy (cadr ipt) r *ch-mark-radius-min*))
)
(ch-ensure-layer *ch-mark-layer* *ch-mark-color*)
(entmake (list '(0 . "CIRCLE") (cons 8 *ch-mark-layer*)
(cons 10 (list cx cy cz)) (cons 40 r)))
)
;;; ------------------------------------------------------------
;;; Ungueltig = nil oder <= 0.
;;; ------------------------------------------------------------
(defun ch-invalid-p (v) (or (null v) (<= v 0)))
;;; ------------------------------------------------------------
;;; Block um dz in Z verschieben (WCS).
;;; ------------------------------------------------------------
(defun ch-move-z (ent dz)
(vla-Move (vlax-ename->vla-object ent)
(vlax-3d-point 0 0 0) (vlax-3d-point 0 0 dz))
)
;;; ------------------------------------------------------------
;;; MONTAGEHOEHE_m schreiben (roher Wert in m). Liegt der rohe Wert
;;; ueber *ch-buehne-schwelle-m*, wird pro Block nach einer Buehne
;;; gefragt und deren Hoehe abgezogen (real = roh - buehne).
;;; Rueckgabe: der geschriebene (evtl. reduzierte) Wert.
;;; ------------------------------------------------------------
(defun ch-write-montage (ent raw lbl / real ans buehne)
(setq real raw)
(if (> raw *ch-buehne-schwelle-m*)
(progn
(initget "Ja Nein")
(setq ans (getkword (strcat "\n " lbl ": Montagehoehe " (rtos raw 2 3)
" m (> " (rtos *ch-buehne-schwelle-m* 2 1)
" m). Buehne vorhanden? [Ja/Nein] <Nein>: ")))
(if (= ans "Ja")
(progn
(setq buehne (getreal "\n Buehnenhoehe in m: "))
(if (and buehne (> buehne 0))
(if (>= buehne raw)
(princ (strcat "\n ! Buehne (" (rtos buehne 2 3)
" m) >= Montagehoehe (" (rtos raw 2 3)
" m) - kein Abzug, roher Wert bleibt."))
(progn
(setq real (- raw buehne))
(princ (strcat "\n Buehne " (rtos buehne 2 3)
" m abgezogen -> " (rtos real 2 3) " m")))
)
)
)
)
)
)
(ch-set-att ent "MONTAGEHOEHE_m" (rtos real 2 3))
real
)
;;; ============================================================
;;; HAUPTBEFEHL (Phase 1 + 2)
;;; ============================================================
(defun c:HOEHEN_CHECK ( / ss i idx id items it ent ed nm lbl zc meas kez kaz
montage inp delta mss
n-kreisel n-vf n-gf n-fixed n-marked n-fehler)
(if (not (ch-ensure-vfcore))
(progn
(princ "\n>>> FEHLER: vf_core (extract-ks-from-block-raw) nicht geladen.")
(princ "\n Bitte das SSG_LIB-Menue laden oder DXFM_LISP setzen.")
(princ)
(exit)
)
)
(setq n-kreisel 0 n-vf 0 n-gf 0 n-fixed 0 n-marked 0 n-fehler 0)
;; Alte Markierungskreise entfernen (Idempotenz)
(setq mss (ssget "_X" (list (cons 0 "CIRCLE") (cons 8 *ch-mark-layer*))))
(if mss (command "_.ERASE" mss ""))
(vl-catch-all-apply '(lambda () (command "_.REGEN")))
(princ "\n============================================")
(princ "\n Hoehen-Check (Phase 1-3)")
(princ "\n============================================")
(setq ss (ssget "_X" '((0 . "INSERT"))))
(if (null ss)
(princ "\n Keine Bloecke gefunden.")
(progn
;; Kandidaten (KREISEL/VF/GF) sammeln und nach ID-Attribut sortieren
(setq items nil i 0 idx 0)
(while (< i (sslength ss))
(setq ent (ssname ss i)
nm (strcase (cdr (assoc 2 (entget ent)))))
(if (or (wcmatch nm "KREISEL_*") (wcmatch nm "VF_*") (wcmatch nm "GF_*"))
(progn
(setq id (ch-get-att-str ent "ID"))
(setq items (cons (list (if (and id (/= id "")) (atoi id) 999999)
ent idx)
items))
(setq idx (1+ idx))))
(setq i (1+ i))
)
(setq items (vl-sort items 'ch-id<))
(if (> (length items) 0)
(princ (strcat "\n (" (itoa (length items))
" Bloecke, Verarbeitung in ID-Reihenfolge)")))
;; in ID-Reihenfolge verarbeiten
(foreach it items
(setq ent (cadr it)
ed (entget ent)
nm (strcase (cdr (assoc 2 ed)))
lbl (cdr (assoc 2 ed)))
(cond
;; ===================== KREISEL =====================
((wcmatch nm "KREISEL_*")
(setq n-kreisel (1+ n-kreisel))
(setq zc (caddr (cdr (assoc 10 ed))))
(if (null zc) (setq zc 0.0))
(if (ch-invalid-p zc)
;; --- ungueltig: eingeben/verschieben oder markieren ---
(progn
(setq inp (getreal (strcat "\n " lbl " ungueltige Hoehe ("
(rtos zc 2 0)
" mm). Neue Hoehe in mm [ENTER=markieren]: ")))
(if (and inp (> inp 0))
(progn
(ch-move-z ent (- inp zc))
(setq zc inp)
(ch-set-att ent "HOEHE" (rtos zc 2 0))
(setq montage (ch-write-montage ent (/ zc 1000.0) lbl))
(setq n-fixed (1+ n-fixed))
(princ (strcat "\n -> verschoben & gesetzt: HOEHE=" (rtos zc 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
(progn
(ch-mark ent)
(setq n-marked (1+ n-marked))
(princ (strcat "\n -> markiert (Layer " *ch-mark-layer*
"), spaeter anpassen")))
)
)
;; --- gueltig ---
(progn
(ch-set-att ent "HOEHE" (rtos zc 2 0))
(setq montage (ch-write-montage ent (/ zc 1000.0) lbl))
(princ (strcat "\n " lbl ": HOEHE=" (rtos zc 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
)
)
;; ===================== VF / GF =====================
((or (wcmatch nm "VF_*") (wcmatch nm "GF_*"))
(if (wcmatch nm "GF_*") (setq n-gf (1+ n-gf)) (setq n-vf (1+ n-vf)))
(setq meas (ch-measure-vfgf ent) kez (car meas) kaz (cadr meas))
(cond
;; --- nicht messbar -> markieren ---
((or (null kez) (null kaz))
(setq n-fehler (1+ n-fehler))
(ch-mark ent)
(setq n-marked (1+ n-marked))
(princ (strcat "\n " lbl ": ! KS nicht messbar (VON="
(if kez (rtos kez 2 0) "?") ", BIS="
(if kaz (rtos kaz 2 0) "?") ") -> markiert")))
;; --- ungueltig (<=0) -> eingeben/verschieben oder markieren ---
((or (ch-invalid-p kez) (ch-invalid-p kaz))
(setq inp (getreal (strcat "\n " lbl " ungueltig (VON=" (rtos kez 2 0)
", BIS=" (rtos kaz 2 0)
"). KS_EIN-Hoehe in mm [ENTER=markieren]: ")))
(if (and inp (> inp 0))
(progn
(setq delta (- inp kez))
(ch-move-z ent delta)
(setq kez inp kaz (+ kaz delta))
(if (or (ch-invalid-p kez) (ch-invalid-p kaz))
(progn
(ch-mark ent)
(setq n-marked (1+ n-marked))
(princ (strcat "\n -> verschoben, aber BIS weiter ungueltig ("
(rtos kaz 2 0) " mm) -> markiert")))
(progn
(ch-set-att ent "HOEHE_VON_mm" (rtos kez 2 0))
(ch-set-att ent "HOEHE_BIS_mm" (rtos kaz 2 0))
(setq montage (ch-write-montage ent
(if (wcmatch nm "GF_*")
(/ kez 1000.0)
(/ (+ kez kaz) 2000.0)) lbl))
(setq n-fixed (1+ n-fixed))
(princ (strcat "\n -> verschoben & gesetzt: VON=" (rtos kez 2 0)
", BIS=" (rtos kaz 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
)
)
(progn
(ch-mark ent)
(setq n-marked (1+ n-marked))
(princ (strcat "\n -> markiert (Layer " *ch-mark-layer*
"), spaeter anpassen")))
)
)
;; --- gueltig ---
(t
(ch-set-att ent "HOEHE_VON_mm" (rtos kez 2 0))
(ch-set-att ent "HOEHE_BIS_mm" (rtos kaz 2 0))
(setq montage (ch-write-montage ent
(if (wcmatch nm "GF_*")
(/ kez 1000.0)
(/ (+ kez kaz) 2000.0)) lbl))
(princ (strcat "\n " lbl ": HOEHE_VON_mm=" (rtos kez 2 0)
", HOEHE_BIS_mm=" (rtos kaz 2 0)
" -> MONTAGEHOEHE_m=" (rtos montage 2 3))))
)
)
)
)
(princ (strcat "\n--------------------------------------------"
"\n Kreisel: " (itoa n-kreisel)
" VF: " (itoa n-vf)
" GF: " (itoa n-gf)
"\n korrigiert (verschoben): " (itoa n-fixed)
" markiert: " (itoa n-marked)
" nicht messbar: " (itoa n-fehler)))
(if (> n-marked 0)
(princ (strcat "\n Markierte Bloecke: Layer '" *ch-mark-layer*
"' - spaeter Hoehe anpassen und erneut ausfuehren.")))
(princ "\n Hinweis: Phase 1-3 - kein QSAVE (UNDO moeglich).")
)
)
(princ "\n>>> Fertig.")
(princ)
)
(princ "\n>>> check_hoehen.lsp geladen (Phase 1-3). Befehl: HOEHEN_CHECK")
(princ)
Lisp/count_sep_scan.lsp
+173 -37
View File
@@ -19,6 +19,15 @@
;;; - Ein optionaler Toleranzrand (*senstol*) vergroessert die
;;; Box, damit Sensoren knapp am Rand noch erfasst werden.
;;;
;;; Zusaetzlich:
;;; - Bei zugeordneten Sensoren wird die Bezeichnung des ILS-Blocks
;;; (Attribut "Bezeichnung", Fallback Blockname) in das Sensor-
;;; Attribut *zuordnung-tag* geschrieben.
;;; - Nicht zugeordnete Sensoren werden mit einem Kreis auf dem
;;; Layer *mark-layer* markiert (zentriert auf den Sensor).
;;; - Der Befehl ist wiederholbar: alte Markierungskreise werden
;;; zu Beginn entfernt.
;;;
;;; Aufruf: ZAEHLE_SEP_SCAN
;;; Laden: per APPLOAD oder (load "count_sep_scan")
;;; ============================================================
@@ -44,6 +53,18 @@
;; ANZAHL_SEPARATOR und werden bei jedem Lauf frisch gezaehlt.
(setq *intern-separator-pattern* "STAUSTRECKE_SEPARATOR_SP*")
;; Attribut-Tag im Scanner-/Separator-Block, in das die Bezeichnung
;; des zugeordneten ILS-Blocks geschrieben wird (Gross/Klein egal).
(setq *zuordnung-tag* "zuordnung")
;; Markierung nicht zugeordneter Sensoren: Kreis auf eigenem Layer.
(setq *mark-layer* "S_SENSOR_UNZUGEORDNET")
(setq *mark-color* 2) ;; 2 = Gelb
;; Kreisradius = Faktor * halbe XY-Diagonale der Sensor-Box,
;; mindestens *mark-radius-min* (mm).
(if (null *mark-radius-factor*) (setq *mark-radius-factor* 1.5))
(if (null *mark-radius-min*) (setq *mark-radius-min* 500.0))
;;; ------------------------------------------------------------
;;; ILS-Block-Erkennung und zugehoerige Attribut-Tags
;;; Alle ILS-Bloecke (Kreisel / VF / GF) verwenden einheitlich
@@ -185,19 +206,26 @@
;;; Rueckgabe: T wenn Tag gefunden und gesetzt, sonst nil.
;;; ------------------------------------------------------------
(defun cs-set-att (ins tag val / e ed done ok)
(setq e (entnext ins) done nil ok nil)
(while (and e (not done))
(setq ed (entget e))
(cond
((= (cdr (assoc 0 ed)) "ATTRIB")
(if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
(progn
(entmod (subst (cons 1 val) (assoc 1 ed) ed))
(entupd e)
(setq ok t))))
((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
(setq done nil ok nil)
;; Nur iterieren, wenn der INSERT ueberhaupt Attribute fuehrt (66=1),
;; sonst wuerde entnext in fremde Objekte weiterlaufen.
(if (= (cdr (assoc 66 (entget ins))) 1)
(progn
(setq e (entnext ins))
(while (and e (not done))
(setq ed (entget e))
(cond
((= (cdr (assoc 0 ed)) "ATTRIB")
(if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
(progn
(entmod (subst (cons 1 val) (assoc 1 ed) ed))
(entupd e)
(setq ok t))))
((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
)
(setq e (entnext e))
)
)
(setq e (entnext e))
)
ok
)
@@ -231,16 +259,105 @@
n
)
;;; ------------------------------------------------------------
;;; Attributwert (String) an einem INSERT lesen. "" wenn nicht
;;; vorhanden. Tag ohne Gross/Klein-Unterscheidung.
;;; ------------------------------------------------------------
(defun cs-get-att-str (ins tag / e ed done val)
(setq done nil val "")
(if (= (cdr (assoc 66 (entget ins))) 1)
(progn
(setq e (entnext ins))
(while (and e (not done))
(setq ed (entget e))
(cond
((= (cdr (assoc 0 ed)) "ATTRIB")
(if (= (strcase (cdr (assoc 2 ed))) (strcase tag))
(progn (setq val (cdr (assoc 1 ed))) (setq done t))))
((= (cdr (assoc 0 ed)) "SEQEND") (setq done t))
)
(setq e (entnext e))
)
)
)
val
)
;;; ------------------------------------------------------------
;;; Bezeichnung eines ILS-Blocks ermitteln: Attribut "Bezeichnung",
;;; Fallback auf den Blocknamen.
;;; ------------------------------------------------------------
(defun cs-carrier-label (ent nm / bez)
(setq bez (cs-get-att-str ent "Bezeichnung"))
(if (and bez (/= bez "")) bez nm)
)
;;; ------------------------------------------------------------
;;; Layer anlegen (falls fehlend), ohne den aktuellen Layer zu aendern.
;;; ------------------------------------------------------------
(defun cs-ensure-layer (name color / lay ed)
(if (tblsearch "LAYER" name)
;; Layer existiert bereits: Standardfarbe angleichen
(progn
(setq lay (tblobjname "LAYER" name))
(setq ed (entget lay))
(if (assoc 62 ed)
(entmod (subst (cons 62 color) (assoc 62 ed) ed)))
)
;; Layer neu anlegen
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 name)
(cons 70 0)
(cons 62 color)
(cons 6 "Continuous")))
)
)
;;; ------------------------------------------------------------
;;; Nicht zugeordneten Sensor mit einem Kreis markieren, zentriert
;;; auf die Sensor-Geometrie. Radius aus der XY-Box des Sensors
;;; (Faktor), mindestens *mark-radius-min*.
;;; ------------------------------------------------------------
(defun cs-mark-unassigned (ent / bb ipt cx cy cz r)
(setq bb (cs-bbox ent))
(setq ipt (cdr (assoc 10 (entget ent))))
(setq cz (if (and ipt (caddr ipt)) (caddr ipt) 0.0))
(if bb
(progn
(setq cx (/ (+ (nth 0 bb) (nth 2 bb)) 2.0)
cy (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
(setq r (* *mark-radius-factor*
(/ (distance (list (nth 0 bb) (nth 1 bb))
(list (nth 2 bb) (nth 3 bb))) 2.0)))
(if (< r *mark-radius-min*) (setq r *mark-radius-min*)))
(progn
(setq cx (car ipt) cy (cadr ipt) r *mark-radius-min*))
)
(cs-ensure-layer *mark-layer* *mark-color*)
(entmake (list '(0 . "CIRCLE")
(cons 8 *mark-layer*)
(cons 10 (list cx cy cz))
(cons 40 r)))
)
;;; ============================================================
;;; HAUPTBEFEHL
;;; ============================================================
(defun c:ZAEHLE_SEP_SCAN ( / ss i ent ed nm tags bb cx cy
carriers scanpts seppts kind pt
(defun c:ZAEHLE_SEP_SCAN ( / ss i ent ed nm tags bb cx cy label
carriers scanlist seplist kind pt
scanCounts sepCounts
rec en nm2 ns nsep internSep newS newP
s sent spt
n-scan-unassigned n-sep-unassigned
n-zuordnung-fehlt mss
okS okP)
(setq carriers nil scanpts nil seppts nil)
(setq carriers nil scanlist nil seplist nil n-zuordnung-fehlt 0)
;; Alte Markierungskreise entfernen (Idempotenz)
(setq mss (ssget "_X" (list (cons 0 "CIRCLE") (cons 8 *mark-layer*))))
(if mss (command "_.ERASE" mss ""))
;; Vor der Extents-Berechnung einmal regenerieren, damit
;; vla-getboundingbox verlaessliche Werte liefert.
@@ -265,47 +382,62 @@
(progn
(setq cx (/ (+ (nth 0 bb) (nth 2 bb)) 2.0))
(setq cy (/ (+ (nth 1 bb) (nth 3 bb)) 2.0))
(setq label (cs-carrier-label ent nm))
(setq carriers
(cons (list ent (car tags) (cadr tags)
(nth 0 bb) (nth 1 bb) (nth 2 bb) (nth 3 bb)
cx cy)
cx cy label)
carriers)))
(princ (strcat "\n! Bounding-Box fehlgeschlagen fuer ILS-Block '" nm "'"
(if *cs-last-error*
(strcat " (" *cs-last-error* ")") "")))
)
)
;; --- Sensor ---
;; --- Sensor (Entity + Referenzpunkt merken) ---
(t
(setq kind (cs-sensor-kind nm))
(if kind
(progn
(setq pt (cs-sensor-point ent ed kind))
(if (eq kind 'scanner)
(setq scanpts (cons pt scanpts))
(setq seppts (cons pt seppts)))))
(setq scanlist (cons (list ent pt) scanlist))
(setq seplist (cons (list ent pt) seplist)))))
)
)
(setq i (1+ i))
)
;; --- 2. Sensoren den ILS-Bloecken zuordnen ---
;; --- 2. Sensoren zuordnen: zuordnung schreiben bzw. markieren ---
(setq scanCounts nil sepCounts nil
n-scan-unassigned 0 n-sep-unassigned 0)
(foreach pt scanpts
(setq rec (cs-assign pt carriers))
(foreach s scanlist
(setq sent (car s) spt (cadr s))
(setq rec (cs-assign spt carriers))
(if rec
(setq scanCounts (cs-bump scanCounts (car rec)))
(setq n-scan-unassigned (1+ n-scan-unassigned))))
(progn
(setq scanCounts (cs-bump scanCounts (car rec)))
(if (not (cs-set-att sent *zuordnung-tag* (nth 9 rec)))
(setq n-zuordnung-fehlt (1+ n-zuordnung-fehlt))))
(progn
(setq n-scan-unassigned (1+ n-scan-unassigned))
(cs-set-att sent *zuordnung-tag* "")
(cs-mark-unassigned sent))))
(foreach pt seppts
(setq rec (cs-assign pt carriers))
(foreach s seplist
(setq sent (car s) spt (cadr s))
(setq rec (cs-assign spt carriers))
(if rec
(setq sepCounts (cs-bump sepCounts (car rec)))
(setq n-sep-unassigned (1+ n-sep-unassigned))))
(progn
(setq sepCounts (cs-bump sepCounts (car rec)))
(if (not (cs-set-att sent *zuordnung-tag* (nth 9 rec)))
(setq n-zuordnung-fehlt (1+ n-zuordnung-fehlt))))
(progn
(setq n-sep-unassigned (1+ n-sep-unassigned))
(cs-set-att sent *zuordnung-tag* "")
(cs-mark-unassigned sent))))
;; --- 3. Attribute setzen und Bericht ausgeben ---
;; --- 3. ANZAHL-Attribute setzen und Bericht ausgeben ---
(princ "\n============================================")
(princ "\n Sensor-Zaehlung je ILS-Block")
(princ "\n============================================")
@@ -322,8 +454,8 @@
;; Separator = interne Kette-Separatoren + neu zugeordnete
(setq newS ns)
(setq newP (+ internSep nsep))
;; gefundene Anzahlen melden
(princ (strcat "\n " nm2
;; gefundene Anzahlen melden (mit Bezeichnung/Label)
(princ (strcat "\n " nm2 " [" (nth 9 rec) "]"
": Scanner(neu)=" (itoa ns)
", Separator intern=" (itoa internSep)
" + manuell=" (itoa nsep)))
@@ -341,14 +473,18 @@
)
(princ (strcat "\n--------------------------------------------"
"\n ILS-Bloecke gesamt: " (itoa (length carriers))
"\n Scanner gesamt: " (itoa (length scanpts))
"\n Scanner gesamt: " (itoa (length scanlist))
" (nicht zugeordnet: " (itoa n-scan-unassigned) ")"
"\n Separator gesamt: " (itoa (length seppts))
"\n Separator gesamt: " (itoa (length seplist))
" (nicht zugeordnet: " (itoa n-sep-unassigned) ")"))
(if (or (> n-scan-unassigned 0) (> n-sep-unassigned 0))
(princ (strcat "\n Hinweis: Nicht zugeordnete Sensoren liegen"
"\n ausserhalb aller ILS-Block-Boxen. Ggf. *senstol*"
"\n erhoehen oder Platzierung pruefen.")))
(if (> (+ n-scan-unassigned n-sep-unassigned) 0)
(princ (strcat "\n " (itoa (+ n-scan-unassigned n-sep-unassigned))
" nicht zugeordnete(r) Sensor(en) mit Kreis markiert"
" (Layer '" *mark-layer* "').")))
(if (> n-zuordnung-fehlt 0)
(princ (strcat "\n WARNUNG: " (itoa n-zuordnung-fehlt)
" zugeordnete(r) Sensor(en) ohne Attribut '"
*zuordnung-tag* "' - Bezeichnung nicht schreibbar.")))
;; --- 4. Zeichnung speichern ---
(princ "\n--------------------------------------------")
Lisp/ssg_core.lsp
+46
View File
@@ -73,6 +73,52 @@
)
;; ------------------------------------------------------------
;; BLOCK-WRAP MIT GARANTIERT WELTPARALLELEM BKS
;; ------------------------------------------------------------
;; Fasst die Entities in ss zu einem Block bname zusammen und fuegt ihn am
;; Welt-Punkt basispkt-welt wieder ein. Setzt das BKS dazu temporaer hart
;; auf Welt und stellt es danach wieder her.
;;
;; Hintergrund (31.95mm-Z-Versatz-Bug): (command "_.-BLOCK"/"_.INSERT" ...)
;; rechnet Punktargumente im AKTUELLEN BKS. Bei einem vom Welt-KS
;; abweichenden BKS ging der korrekt via (trans ...) umgerechnete Z-Wert
;; beim _.-BLOCK -> _.INSERT-Rundlauf verloren, sodass der fertige Block
;; um die BKS-Hoehe (z.B. 31.95mm) in Z verschoben wurde - obwohl die
;; ELEVATION-Systemvariable 0 war. Bei BKS=Welt liegen Objekte, Basispunkt
;; und Einfuegepunkt alle bei WCS-Z ohne jede Umrechnungs-Mehrdeutigkeit;
;; ein bei WCS-Z=0 platziertes Element bleibt garantiert bei Z=0.
;;
;; Rueckgabe: das eingefuegte INSERT-Objekt (entlast).
(defun ssg-block-wrap-welt (bname basispkt-welt ss / alt-attreq alt-attdia alt-elev alt-osmode)
(setq alt-attreq (getvar "ATTREQ")
alt-attdia (getvar "ATTDIA")
alt-elev (getvar "ELEVATION")
alt-osmode (getvar "OSMODE"))
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
;; OSMODE=0: laufenden Objektfang abschalten. Sonst kann _.INSERT den
;; explizit uebergebenen Einfuegepunkt (X,Y,0) auf ein an derselben X/Y-Stelle
;; liegendes Objekt umfangen - z.B. den gefangenen Basispunkt bei Z=12000 ->
;; der Block landet auf 12000 statt 0 (12000er-Bug).
(setvar "OSMODE" 0)
;; ELEVATION=0: sonst kann _.INSERT die Z-Hoehe aus der aktuellen Elevation
;; statt aus dem uebergebenen Punkt ziehen.
(setvar "ELEVATION" 0.0)
;; BKS temporaer auf Welt; _Previous stellt danach das vorige BKS wieder her.
(command "_.UCS" "_World")
;; basispkt-welt ist ein Welt-Punkt; bei BKS=Welt ist er zugleich BKS-Punkt.
(command "_.-BLOCK" bname basispkt-welt ss "")
(command "_.INSERT" bname basispkt-welt 1.0 1.0 0.0)
(command "_.UCS" "_Previous")
(setvar "OSMODE" alt-osmode)
(setvar "ELEVATION" alt-elev)
(setvar "ATTREQ" alt-attreq)
(setvar "ATTDIA" alt-attdia)
(entlast)
)
;; ------------------------------------------------------------
;; BENUTZER-ABFRAGEN
;; ------------------------------------------------------------
Lisp/vf_core.lsp
+17 -10
View File
@@ -1104,12 +1104,11 @@
(setq vf-bname (strcat "VF_" (itoa vf-nummer)))
(if (> (sslength vf-ss) 0)
(progn
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(command "_.-BLOCK" vf-bname startpunkt vf-ss "")
(command "_.INSERT" vf-bname startpunkt 1.0 1.0 0.0)
(setvar "ATTREQ" 1)
(setq vf-insert (entlast))
;; Block definieren und einfuegen mit garantiert weltparallelem BKS.
;; startpunkt ist ein Welt-Punkt; ssg-block-wrap-welt setzt das BKS
;; temporaer auf Welt (verhindert den 31.95mm-Z-Versatz bei
;; abweichendem BKS) und stellt es danach wieder her.
(setq vf-insert (ssg-block-wrap-welt vf-bname startpunkt vf-ss))
(setq montagehoehe-m (/ (+ hoehe-von hoehe-bis) 2000.0))
;; L_GF_m: kommagetrennte Segmentlaengen in Metern (vorne,hinten),
;; analog L_GF_m in Gefaellestrecke.lsp.
@@ -1196,7 +1195,7 @@
best-winkel L_GF L_GF1 L_GF2 L_VF
idx eintrag wahl antwort verteilung-modus
n-scanner vf-nummer hoehe-von hoehe-bis lastEnt
staustrecke-basis)
staustrecke-basis vf-insert)
(princ "\n=========================================")
(princ (ssg-text "vfc-banner-titel"))
@@ -1440,9 +1439,17 @@
(list deltaL deltaH richtung best-winkel L_GF1 L_GF2 L_VF startpunkt seite hz))
;; Gemeinsame VF_*-Block-Erstellung
(vf-block-erstellen anlage-typ seite vf-nummer n-scanner
hoehe-von hoehe-bis deltaH deltaL L_VF L_GF1 L_GF2
richtung best-winkel startpunkt lastEnt hz)
(setq vf-insert
(vf-block-erstellen anlage-typ seite vf-nummer n-scanner
hoehe-von hoehe-bis deltaH deltaL L_VF L_GF1 L_GF2
richtung best-winkel startpunkt lastEnt hz))
;; Standard-Bloecke aus dem interaktiven Konsolen-Ablauf ebenfalls mit der
;; SSG_VF_EDIT-XDATA markieren - sie sind (wie die Dialog-Variante) aus
;; Attributen + hz verlustfrei rekonstruierbar, also per Doppelklick
;; (c:VARIOFOERDERER_EDIT) editierbar. Etage/Linienzug bleiben unmarkiert.
(if (and vf-insert (= anlage-typ "standard"))
(vfs-xdata-schreiben vf-insert hz))
(princ "\n=========================================")
)
Lisp/vf_linienzug.lsp
+5 -6
View File
@@ -821,12 +821,11 @@
(ssadd ent vfl-ss)
(setq ent (entnext ent))
)
(setvar "ATTREQ" 0)
(setvar "ATTDIA" 0)
(command "_.-BLOCK" vfl-bname startpunkt vfl-ss "")
(command "_.INSERT" vfl-bname startpunkt 1.0 1.0 0.0)
(setvar "ATTREQ" 1)
(setq vfl-insert (entlast))
;; Block definieren und einfuegen mit garantiert weltparallelem BKS.
;; startpunkt ist ein Welt-Punkt; ssg-block-wrap-welt setzt das BKS
;; temporaer auf Welt (verhindert den 31.95mm-Z-Versatz bei abweichendem
;; BKS, siehe Kommentar dort) und stellt es danach wieder her.
(setq vfl-insert (ssg-block-wrap-welt vfl-bname startpunkt vfl-ss))
;; Werte (volle Liste; nicht vorhandene Tags ignoriert ssg-attrib-set-on)
(ssg-attrib-set-on vfl-insert
(list