From b962872071787385415e22211f642a68034723c8 Mon Sep 17 00:00:00 2001 From: Yuelin Wang Date: Tue, 21 Jul 2026 14:11:29 +0200 Subject: [PATCH] HOEHEN_CHECK - misst/schreibt Hoehen-Attribute (Kreisel/VF/GF), markiert ungueltige Hoehen auf Layer S_HOEHE_PRUEFEN, Buehnenabzug ab 2m --- Lisp/check_hoehen.lsp | 452 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 452 insertions(+) create mode 100644 Lisp/check_hoehen.lsp diff --git a/Lisp/check_hoehen.lsp b/Lisp/check_hoehen.lsp new file mode 100644 index 0000000..51c5ae6 --- /dev/null +++ b/Lisp/check_hoehen.lsp @@ -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] : "))) + (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)