453 lines
18 KiB
Common Lisp
453 lines
18 KiB
Common Lisp
;;; ============================================================
|
|
;;; 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)
|