506 lines
15 KiB
Common Lisp
506 lines
15 KiB
Common Lisp
;; ============================================================
|
|
;; SSG_CORE.LSP - Kernbibliothek: Umgebung, Fehler, Dialog
|
|
;; Allgemeingueltige Hilfsfunktionen fuer AutoCAD-LISP Makros
|
|
;; Ursprung: ACADSST/MENU/ssg.lsp, pu1pu2.lsp (Schoenenberger)
|
|
;; Bereinigt und verallgemeinert: 2025
|
|
;; ============================================================
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; UMGEBUNGSSICHERUNG
|
|
;; Sichert Systemvariablen vor Makroausfuehrung und stellt
|
|
;; sie danach wieder her. Wird immer als Paar verwendet:
|
|
;; (ssg-start "Titel" '(("OSMODE") ("ORTHOMODE")))
|
|
;; ... Makrocode ...
|
|
;; (ssg-end)
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun ssg-start (titel zusatz-vars / xlen xpos xvar)
|
|
;; titel - Anzeigename des Makros
|
|
;; zusatz-vars - Liste zusaetzlicher Variablen z.B. '(("OSMODE")("ORTHOMODE"))
|
|
;; Immer CLAYER und CMDECHO werden automatisch gesichert.
|
|
(setq _ssg-olderr *error*
|
|
*error* (function ssg-errhan)
|
|
_ssg-cavar (append '(("CLAYER") ("CMDECHO")) zusatz-vars)
|
|
xlen (length _ssg-cavar)
|
|
xpos 0
|
|
)
|
|
(repeat xlen
|
|
(setq xvar (car (nth xpos _ssg-cavar))
|
|
_ssg-cavar (subst (cons xvar (getvar xvar))
|
|
(nth xpos _ssg-cavar) _ssg-cavar)
|
|
xpos (1+ xpos)
|
|
)
|
|
)
|
|
(setvar "CMDECHO" 0)
|
|
(command "_undo" "_G")
|
|
(graphscr)
|
|
(if titel (prompt (strcat "\n***** " titel " *****\n")))
|
|
(princ)
|
|
)
|
|
|
|
(defun ssg-end (/ xpos xlen xvar)
|
|
(if _ssg-cavar
|
|
(progn
|
|
(command)
|
|
(command "_undo" "_E")
|
|
(setq xpos 1
|
|
xlen (length _ssg-cavar)
|
|
)
|
|
(if (/= (getvar "CLAYER") (caar _ssg-cavar))
|
|
(command "_LAYER" "_SE" (cdar _ssg-cavar) "")
|
|
)
|
|
(repeat (1- xlen)
|
|
(setq xvar (nth xpos _ssg-cavar)
|
|
xpos (1+ xpos)
|
|
)
|
|
(setvar (car xvar) (cdr xvar))
|
|
)
|
|
)
|
|
)
|
|
(if _ssg-olderr (setq *error* _ssg-olderr))
|
|
(princ)
|
|
)
|
|
|
|
(defun ssg-errhan (em)
|
|
(if (= em "Function cancelled")
|
|
(princ)
|
|
(progn (princ "\nFehler: ") (princ em))
|
|
)
|
|
(command)
|
|
(command)
|
|
(ssg-end)
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; BENUTZER-ABFRAGEN
|
|
;; ------------------------------------------------------------
|
|
|
|
;; Ja/Nein-Abfrage mit konfigurierbarem Default
|
|
;; defa = T -> Default ist "Yes" (Eingabe noetig um "No" zu waehlen)
|
|
;; defa = nil -> Default ist "No"
|
|
;; Rueckgabe: T wenn "No" gewaehlt (also Ablehnung), nil wenn "Yes"
|
|
(defun ssg-ques (prompt-text defa)
|
|
(if defa
|
|
(progn
|
|
(initget 1 "Yes No Yes")
|
|
(= (getkword (strcat "\n" prompt-text " Y/N <Y>: ")) "No")
|
|
)
|
|
(progn
|
|
(initget 1 "Yes No No")
|
|
(= (getkword (strcat "\n" prompt-text " Y/N <N>: ")) "Yes")
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Fehlermeldung mit optionalem Signalton
|
|
;; ssg-bell = T -> kein Ton; nil -> Ton ausgeben
|
|
(defun ssg-emsg (text)
|
|
(if (not ssg-bell) (prompt "\007"))
|
|
(terpri)
|
|
(prompt text)
|
|
(terpri)
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; LAYER-HILFSFUNKTIONEN
|
|
;; ------------------------------------------------------------
|
|
|
|
;; Layer eines angeklickten Objektes ermitteln
|
|
;; txt = Prompt-Text fuer Objektauswahl
|
|
;; Rueckgabe: Layername als String, nil wenn Abbruch
|
|
(defun ssg-get-layer (txt / sel)
|
|
(if (setq sel (entsel txt))
|
|
(cdr (assoc 8 (entget (car sel))))
|
|
)
|
|
)
|
|
|
|
;; Alle Objekte eines bestimmten Layers als Auswahlsatz liefern
|
|
;; lay-name = Layername; ent-typ = Entitaetstyp z.B. "LINE" (nil = alle)
|
|
(defun ssg-layer-ss (lay-name ent-typ)
|
|
(if ent-typ
|
|
(ssget "X" (list (cons 0 ent-typ) (cons 8 lay-name)))
|
|
(ssget "X" (list (cons 8 lay-name)))
|
|
)
|
|
)
|
|
|
|
;; Layer anlegen (falls nicht vorhanden) und optional setzen
|
|
;; lay-name = Name; color = Farbnummer als String z.B. "2"; set-aktiv = T/nil
|
|
(defun ssg-make-layer (lay-name color set-aktiv)
|
|
(if set-aktiv
|
|
(command "_LAYER" "_M" lay-name "_CO" color lay-name "")
|
|
(command "_LAYER" "_N" lay-name "_CO" color lay-name "")
|
|
)
|
|
)
|
|
|
|
;; Auswahlsatz-Iteration: Funktion fuer jedes Element aufrufen
|
|
;; ss = Auswahlsatz; func = Funktion mit einem Parameter (entity-name)
|
|
(defun ssg-ss-foreach (ss func / i ename)
|
|
(if ss
|
|
(progn
|
|
(setq i 0)
|
|
(while (setq ename (ssname ss i))
|
|
(func ename)
|
|
(setq i (1+ i))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Alle Elemente eines Auswahlsatzes hervorheben/zuruecksetzen
|
|
;; ss = Auswahlsatz; modus = 3 (hervorheben) / 4 (invertiert) / 0 (normal)
|
|
(defun ssg-ss-redraw (ss modus / i ename)
|
|
(if ss
|
|
(progn
|
|
(setq i 0)
|
|
(while (setq ename (ssname ss i))
|
|
(redraw ename modus)
|
|
(setq i (1+ i))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Auswahlsatz zu einem anderen Auswahlsatz hinzufuegen (in-place)
|
|
;; src-ss = Quell-Auswahlsatz; dest-ss = Ziel-Auswahlsatz (wird modifiziert)
|
|
(defun ssg-ss-add (src-ss dest-ss / i ename)
|
|
(if (null dest-ss) (setq dest-ss (ssadd)))
|
|
(setq i 0)
|
|
(while (setq ename (ssname src-ss i))
|
|
(ssadd ename dest-ss)
|
|
(redraw ename 3)
|
|
(setq i (1+ i))
|
|
)
|
|
dest-ss
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; BLOCK-OPERATIONEN
|
|
;; ------------------------------------------------------------
|
|
|
|
;; Zeitstempel als YYYYMMDDHHMMSS erzeugen (fuer eindeutige Blocknamen)
|
|
(defun ssg-timestamp ( / cd ds ts)
|
|
(setq cd (rtos (getvar "CDATE") 2 6))
|
|
;; cd = "20260518.143052" -> Punkt entfernen
|
|
(setq ds (substr cd 1 8))
|
|
(setq ts (substr cd 10 6))
|
|
(strcat ds ts)
|
|
)
|
|
|
|
;; Eindeutigen Blocknamen aus Einfuegepunkt + Zeitstempel erzeugen
|
|
;; pt = Einfuegepunkt (Liste); Rueckgabe: Blockname als String
|
|
(defun ssg-make-blockname (pt / k1 k2)
|
|
(setq k1 (strcat (itoa (abs (fix (car pt))))
|
|
(itoa (abs (fix (cadr pt))))
|
|
(itoa (abs (fix (caddr pt)))))
|
|
k2 (substr (rtos (getvar "cdate") 2 9) 10 9)
|
|
)
|
|
(strcat k1 k2)
|
|
)
|
|
|
|
;; Einzel-Block einfuegen mit Layer anlegen
|
|
;; lay-name = Ziel-Layer; color = Layerfarbe
|
|
;; blk-pfad = vollstaendiger Blockpfad (ohne Erweiterung)
|
|
;; pt = Einfuegepunkt; xscale yscale = Skalierung ("" = 1)
|
|
;; rotation = Drehwinkel als String oder pause fuer interaktiv
|
|
(defun ssg-insert-block (lay-name color blk-pfad pt xscale yscale rotation)
|
|
(ssg-make-layer lay-name color T)
|
|
(command "_insert" blk-pfad pt xscale yscale rotation)
|
|
)
|
|
|
|
;; Block aus Auswahlsatz erstellen und gleich wieder einfuegen
|
|
;; pt = Origin; rotation = Drehwinkel als String
|
|
;; ss = Auswahlsatz der Elemente
|
|
;; Rueckgabe: Blockname (String)
|
|
(defun ssg-make-block (pt rotation ss / bname gefunden)
|
|
(setq bname (ssg-make-blockname pt)
|
|
gefunden (tblsearch "block" bname)
|
|
)
|
|
(if (not gefunden)
|
|
(progn
|
|
(command "_block" bname pt ss "")
|
|
(command "_insert" bname pt "" "" rotation)
|
|
)
|
|
(progn
|
|
(alert (strcat "Blockname '" bname "' existiert bereits - wird uebersprungen."))
|
|
(setq bname (strcat "x" bname))
|
|
(command "_block" bname pt ss "")
|
|
(command "_insert" bname pt "" "" rotation)
|
|
)
|
|
)
|
|
bname
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; ATTRIBUT-OPERATIONEN
|
|
;; ------------------------------------------------------------
|
|
|
|
;; Attribut eines Blocks (letzte Einfuegung) aendern
|
|
;; tag = Attributbezeichner (z.B. "ARTINR")
|
|
;; wert = neuer Wert
|
|
;; ersetzen = T -> vollstaendiger Ersatz; nil -> Anfuegen
|
|
(defun ssg-attrib-set (tag wert ersetzen / obj typ attr-tag attr-wert)
|
|
(setq obj (entlast))
|
|
(while (not (equal (cdr (assoc 0 (entget obj))) "SEQEND"))
|
|
(setq typ (cdr (assoc 0 (entget obj))))
|
|
(if (equal typ "ATTRIB")
|
|
(progn
|
|
(setq attr-tag (cdr (assoc 2 (entget obj)))
|
|
attr-wert (cdr (assoc 1 (entget obj)))
|
|
)
|
|
(if (equal attr-tag tag)
|
|
(if ersetzen
|
|
(entmod (subst (cons 1 wert)
|
|
(assoc 1 (entget obj)) (entget obj)))
|
|
(entmod (subst (cons 1 (strcat attr-wert wert))
|
|
(assoc 1 (entget obj)) (entget obj)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(setq obj (entnext obj))
|
|
)
|
|
)
|
|
|
|
;; Mehrere Attribute eines Blocks auf einmal setzen
|
|
;; attrib-alist = Assoziationsliste '(("TAG1" . "Wert1") ("TAG2" . "Wert2") ...)
|
|
(defun ssg-attrib-set-many (attrib-alist / obj typ tag wert)
|
|
(setq obj (entlast))
|
|
(while (not (equal (cdr (assoc 0 (entget obj))) "SEQEND"))
|
|
(setq typ (cdr (assoc 0 (entget obj))))
|
|
(if (equal typ "ATTRIB")
|
|
(progn
|
|
(setq tag (cdr (assoc 2 (entget obj))))
|
|
(setq wert (cdr (assoc tag attrib-alist)))
|
|
(if (and wert (> (strlen wert) 0))
|
|
(entmod (subst (cons 1 wert)
|
|
(assoc 1 (entget obj)) (entget obj)))
|
|
)
|
|
)
|
|
)
|
|
(setq obj (entnext obj))
|
|
)
|
|
)
|
|
|
|
;; Alle Attribute eines INSERT-Entity als Assoziationsliste lesen.
|
|
;; ent = Entity-Name eines INSERT mit Attributen.
|
|
;; Rueckgabe: (("TAG1" . "Wert1") ("TAG2" . "Wert2") ...) oder nil
|
|
(defun ssg-attrib-read (ent / e ed result)
|
|
(setq e (entnext ent))
|
|
(while e
|
|
(setq ed (entget e))
|
|
(if (equal (cdr (assoc 0 ed)) "SEQEND")
|
|
(setq e nil)
|
|
(progn
|
|
(if (equal (cdr (assoc 0 ed)) "ATTRIB")
|
|
(setq result (cons (cons (cdr (assoc 2 ed)) (cdr (assoc 1 ed))) result))
|
|
)
|
|
(setq e (entnext e))
|
|
)
|
|
)
|
|
)
|
|
(reverse result)
|
|
)
|
|
|
|
;; Default-Attribute aus einer Definitionsliste erzeugen.
|
|
;; attrib-defs = Liste von (TAG DEFAULT) Paaren, z.B. '(("TYP" "A") ("NR" "0"))
|
|
;; Rueckgabe: Assoziationsliste (("TYP" . "A") ("NR" . "0") ...)
|
|
(defun ssg-attrib-defaults (attrib-defs / result)
|
|
(foreach def attrib-defs
|
|
(setq result (cons (cons (car def) (cadr def)) result))
|
|
)
|
|
(reverse result)
|
|
)
|
|
|
|
;; Gegebene Attribute mit Defaults zusammenfuehren.
|
|
;; given = alist mit Ueberschreibungen (darf nil sein)
|
|
;; attrib-defs = Definitionsliste ((TAG DEFAULT) ...)
|
|
;; Rueckgabe: vollstaendige alist mit allen Tags
|
|
(defun ssg-attrib-merge (given attrib-defs / defaults pair existing)
|
|
(setq defaults (ssg-attrib-defaults attrib-defs))
|
|
(if given
|
|
(foreach pair given
|
|
(setq existing (assoc (car pair) defaults))
|
|
(if existing
|
|
(setq defaults (subst pair existing defaults))
|
|
(setq defaults (append defaults (list pair)))
|
|
)
|
|
)
|
|
)
|
|
defaults
|
|
)
|
|
|
|
;; Unsichtbare ATTDEF-Entities bei (0,0) erzeugen.
|
|
;; Muss VOR dem _BLOCK-Befehl aufgerufen werden, damit die ATTDEFs
|
|
;; Teil der Blockdefinition werden.
|
|
;; attrib-defs = Definitionsliste ((TAG DEFAULT) ...)
|
|
;; text-height = Texthoehe der ATTDEFs (z.B. 50.0)
|
|
(defun ssg-attrib-make-defs (attrib-defs text-height / ypos)
|
|
(setq ypos 0.0)
|
|
(foreach def attrib-defs
|
|
(entmake (list
|
|
'(0 . "ATTDEF")
|
|
'(8 . "0")
|
|
(cons 10 (list 0.0 ypos 0.0))
|
|
(cons 40 text-height)
|
|
(cons 1 (cadr def))
|
|
(cons 3 (car def))
|
|
(cons 2 (car def))
|
|
'(70 . 1)
|
|
))
|
|
(setq ypos (- ypos (* text-height 2.0)))
|
|
)
|
|
)
|
|
|
|
;; Attribute eines bestimmten INSERT-Entity setzen (nicht entlast).
|
|
;; ent = Entity-Name des INSERT-Blocks
|
|
;; attrib-alist = (("TAG" . "Wert") ...)
|
|
(defun ssg-attrib-set-on (ent attrib-alist / obj ed typ tag wert)
|
|
(setq obj (entnext ent))
|
|
(while obj
|
|
(setq ed (entget obj))
|
|
(setq typ (cdr (assoc 0 ed)))
|
|
(if (equal typ "SEQEND") (setq obj nil)
|
|
(progn
|
|
(if (equal typ "ATTRIB")
|
|
(progn
|
|
(setq tag (cdr (assoc 2 ed)))
|
|
(setq wert (cdr (assoc tag attrib-alist)))
|
|
(if (and wert (> (strlen wert) 0))
|
|
(progn
|
|
(entmod (subst (cons 1 wert) (assoc 1 ed) ed))
|
|
(entupd obj)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(setq obj (entnext obj))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Assoziationsliste in ATTDEF-Definitionsliste konvertieren.
|
|
;; alist = (("TAG" . "Wert") ...) -> ((TAG Wert) ...)
|
|
;; Passend fuer ssg-attrib-make-defs.
|
|
(defun ssg-attrib-alist-to-defs (alist / result)
|
|
(foreach pair alist
|
|
(setq result (cons (list (car pair) (cdr pair)) result))
|
|
)
|
|
(reverse result)
|
|
)
|
|
|
|
;; Block (.dwg) temporaer einfuegen, Attribute lesen, Block loeschen.
|
|
;; dwg-pfad = vollstaendiger Pfad zur .dwg Datei
|
|
;; Rueckgabe: Assoziationsliste (("TAG" . "Wert") ...) oder nil
|
|
(defun ssg-attrib-read-dwg (dwg-pfad / tmpEnt srcAttribs oldAttreq oldAttdia)
|
|
(if (not (findfile dwg-pfad))
|
|
(progn
|
|
(princ (strcat "\nFEHLER: Block nicht gefunden: " dwg-pfad))
|
|
nil
|
|
)
|
|
(progn
|
|
(setq oldAttreq (getvar "ATTREQ"))
|
|
(setq oldAttdia (getvar "ATTDIA"))
|
|
(setvar "ATTREQ" 0)
|
|
(setvar "ATTDIA" 0)
|
|
(command "_.INSERT" dwg-pfad (list 0.0 0.0 0.0) 1 1 0)
|
|
(setvar "ATTREQ" oldAttreq)
|
|
(setvar "ATTDIA" oldAttdia)
|
|
(setq tmpEnt (entlast))
|
|
(setq srcAttribs (ssg-attrib-read tmpEnt))
|
|
(command "_.ERASE" tmpEnt "")
|
|
srcAttribs
|
|
)
|
|
)
|
|
)
|
|
|
|
;; Attribut eines Blocks anhand seines Handle suchen und aendern
|
|
;; handle = Entity-Handle (String) des INSERT
|
|
;; tag = Attributbezeichner
|
|
;; wert = neuer Wert
|
|
;; ersetzen = T -> ersetzen; nil -> anhaengen
|
|
(defun ssg-attrib-by-handle (handle tag wert ersetzen / e typ blk-tag blk-wert fertig)
|
|
(setq e (entnext)
|
|
fertig nil
|
|
)
|
|
(while (and e (not fertig))
|
|
(setq typ (cdr (assoc 0 (entget e))))
|
|
(if (and (equal (cdr (assoc 5 (entget e))) handle)
|
|
(equal typ "INSERT")
|
|
(equal (cdr (assoc 66 (entget e))) 1)
|
|
)
|
|
(progn
|
|
(while (not (= (cdr (assoc 0 (entget e))) "SEQEND"))
|
|
(if (equal (cdr (assoc 0 (entget e))) "ATTRIB")
|
|
(progn
|
|
(setq blk-tag (cdr (assoc 2 (entget e)))
|
|
blk-wert (cdr (assoc 1 (entget e)))
|
|
)
|
|
(if (equal blk-tag tag)
|
|
(if ersetzen
|
|
(entmod (subst (cons 1 wert)
|
|
(assoc 1 (entget e)) (entget e)))
|
|
(entmod (subst (cons 1 (strcat blk-wert wert))
|
|
(assoc 1 (entget e)) (entget e)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(setq e (entnext e))
|
|
)
|
|
(setq fertig T)
|
|
)
|
|
)
|
|
(setq e (entnext e))
|
|
)
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; DIALOG-STANDARD-PATTERN
|
|
;; Vorlage fuer DCL-Dialoge: laden, initialisieren, starten
|
|
;; Verwendung:
|
|
;; (ssg-dialog-run "pfad/dialog.dcl" "dialog-name" init-fn accept-fn)
|
|
;;
|
|
;; init-fn = Funktion ohne Parameter, setzt Tiles und Actions
|
|
;; accept-fn = Funktion ohne Parameter, liest Tiles aus
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun ssg-dialog-run (dcl-pfad dialog-name init-fn accept-fn / dat)
|
|
(setq dat (load_dialog dcl-pfad))
|
|
(if (not (new_dialog dialog-name dat))
|
|
(progn (alert "Dialog konnte nicht geladen werden.") (exit))
|
|
)
|
|
(if init-fn (init-fn))
|
|
(action_tile "accept" "(if accept-fn (accept-fn)) (done_dialog 1)")
|
|
(action_tile "cancel" "(done_dialog 0)")
|
|
(start_dialog)
|
|
(unload_dialog dat)
|
|
)
|
|
|
|
|
|
;; ------------------------------------------------------------
|
|
;; ZOOM-HILFSFUNKTIONEN
|
|
;; ------------------------------------------------------------
|
|
|
|
;; Aktuelle View-Groesse merken
|
|
(defun ssg-zoom-save ()
|
|
(setq _ssg-view-size (getvar "VIEWSIZE"))
|
|
)
|
|
|
|
;; Auf gespeicherte View-Groesse zurueckschalten (wenn veraendert)
|
|
(defun ssg-zoom-restore ()
|
|
(if (and _ssg-view-size (/= (getvar "VIEWSIZE") _ssg-view-size))
|
|
(command "_ZOOM" "_P")
|
|
)
|
|
)
|
|
|
|
|
|
(prompt "\nssg_core.lsp geladen.")
|
|
(princ)
|