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

[ADD] Block- und Text-Werkzeuge aus Walz (ACADSST) uebernommen

Browse Source 
Neue Module ssg_blocktools.lsp (SSG_BLOCK_COUNT, SSG_BLOCK_DELETE,
SSG_ATTR_ERSETZEN) und ssg_texttools.lsp (SSG_TEXT_ERSETZEN,
SSG_TEXT_PARALLEL, SSG_TEXT_HOEHE, SSG_TEXT_STIL) sowie der generische
Eingabe-Wrapper ssg_input.lsp, dazu Menue-/Lade-Integration,
zweisprachige Texte und Unit-Tests fuer die reinen Kerne.

Co-Authored-By: Claude Sonnet 5 <noreply@anthropic.com>
This commit is contained in:
Michael Stangl
2026-10-07 11:40:11 +02:00
parent 2f9cb7eaed
commit fcb4444ee1
13 changed files with 8260 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Lisp/ssg_texttools.lsp
+285
View File
@@ -0,0 +1,285 @@
;; ============================================================
;; SSG_TEXTTOOLS.LSP - Text-Werkzeuge
;;
;; Ursprung: ACADSST/MENU/CHGTEXT.LSP (Suchen/Ersetzen), PARTEXT.LSP
;; (Tbpl: parallel beschriften), ALTHOEHE.LSP (Tsz), ALTSTIL.LSP (Ts).
;; Neu geschrieben im ssg-Stil (Undo-Gruppe, i18n, ssg-in-*).
;;
;; Befehle:
;; SSG_TEXT_ERSETZEN Zeichenketten in TEXT, MTEXT und Block-
;; Attributen suchen/ersetzen (mit Vorschau)
;; SSG_TEXT_PARALLEL Text parallel zu Linie/Polylinie/Bogen setzen
;; (lesbar ausgerichtet, mit Abstand zur Linie)
;; SSG_TEXT_HOEHE Texthoehe von TEXT/MTEXT aendern
;; SSG_TEXT_STIL Textstil von TEXT/MTEXT aendern
;;
;; Arbeitet in der XY-Ebene des Welt-KS (Textrotation = WKS-Winkel).
;; Setzt ssg_core.lsp, ssg_lang.lsp, ssg_input.lsp und ssg_blocktools.lsp
;; (ssg-bt-wert-neu, ssg-bt-attr-ersetzen-ent) voraus.
;; ============================================================
(vl-load-com)
;; ------------------------------------------------------------
;; REINE HILFSFUNKTIONEN (in test_unit getestet)
;; ------------------------------------------------------------
;; Winkel (Bogenmass) so drehen, dass ein Text lesbar bleibt: Winkel im
;; Bereich (90 Grad, 270 Grad] werden um 180 Grad gedreht. Ergebnis in
;; [0, 2*pi).
(defun ssg-tt-lesbarer-winkel (a)
(setq a (rem a (* 2.0 pi)))
(if (< a 0.0) (setq a (+ a (* 2.0 pi))))
(if (and (> a (+ (/ pi 2.0) 1e-9))
(<= a (+ (* 1.5 pi) 1e-9)))
(setq a (- a pi))
)
(if (< a 0.0) (setq a (+ a (* 2.0 pi))))
a
)
;; Punkt um abstand in Richtung winkel verschieben (2D, Z bleibt erhalten)
(defun ssg-tt-versetzt (p winkel abstand)
(list (+ (car p) (* abstand (cos winkel)))
(+ (cadr p) (* abstand (sin winkel)))
(if (caddr p) (caddr p) 0.0))
)
;; ------------------------------------------------------------
;; AUSWAHL
;; ------------------------------------------------------------
;; Auswahlsatz der angegebenen Typen holen (z.B. "TEXT,MTEXT,INSERT").
;; alle-p = T -> alle im aktuellen Layout, nil -> Benutzerwahl
(defun ssg-tt-ss-holen (alle-p typen)
(if alle-p
(ssget "_X" (list (cons 0 typen) (cons 410 (getvar "CTAB"))))
(ssget (list (cons 0 typen)))
)
)
;; Auswahlsatz -> Liste von Entity-Namen mit Typ-Filter ("TEXT" "MTEXT" ...)
(defun ssg-tt-ss-liste (ss typen / i ent res)
(if ss
(progn
(setq i 0)
(while (setq ent (ssname ss i))
(if (member (cdr (assoc 0 (entget ent))) typen)
(setq res (cons ent res))
)
(setq i (1+ i))
)
)
)
(reverse res)
)
;; ------------------------------------------------------------
;; SUCHEN / ERSETZEN
;; ------------------------------------------------------------
;; TEXT/MTEXT-Inhalte ersetzen (oder nur zaehlen). Rueckgabe: Anzahl Texte.
(defun ssg-tt-text-ersetzen-liste (ents suche ersatz teil-p probe-p
/ n obj alt neu)
(setq n 0)
(foreach ent ents
(setq obj (vlax-ename->vla-object ent)
alt (vla-get-textstring obj)
neu (ssg-bt-wert-neu alt suche ersatz teil-p))
(if neu
(if probe-p
(setq n (1+ n))
(if (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-textstring (list obj neu))))
(setq n (1+ n))
)
)
)
)
n
)
;; Texte + Attribute in einem Auswahlsatz ersetzen/zaehlen.
;; Rueckgabe: (anzahl-texte . anzahl-attribute)
(defun ssg-tt-ersetzen-ss (ss suche ersatz teil-p probe-p)
(cons
(ssg-tt-text-ersetzen-liste
(ssg-tt-ss-liste ss '("TEXT" "MTEXT")) suche ersatz teil-p probe-p)
(ssg-bt-attr-ersetzen-liste
(ssg-tt-ss-liste ss '("INSERT")) "*" suche ersatz teil-p probe-p)
)
)
(defun c:SSG_TEXT_ERSETZEN ( / k-bereich k-modus alle-p ss suche ersatz modus teil-p z)
(setq k-bereich (ssg-text "in-keys-bereich")
k-modus (ssg-text "in-keys-modus")
alle-p (= (ssg-in-keyword (ssg-text "tt-bereich") k-bereich
(ssg-in-first-word k-bereich))
(ssg-in-first-word k-bereich)))
(if (not alle-p) (prompt (ssg-text "tt-auswahl")))
(setq ss (ssg-tt-ss-holen alle-p "TEXT,MTEXT,INSERT"))
(if (null ss)
(prompt (ssg-text "tt-keine-objekte"))
(progn
(setq suche (ssg-in-string (ssg-text "tt-suche") nil))
(if (or (null suche) (= suche ""))
(prompt (ssg-text "tt-abgebrochen"))
(progn
(setq ersatz (ssg-in-string (ssg-text "tt-ersatz") "")
modus (ssg-in-keyword (ssg-text "tt-modus") k-modus
(ssg-in-first-word k-modus))
teil-p (= modus (ssg-in-first-word k-modus)))
(setq z (ssg-tt-ersetzen-ss ss suche ersatz teil-p T))
(cond
((= 0 (+ (car z) (cdr z))) (prompt (ssg-text "tt-nichts")))
((ssg-in-yesno (ssg-textf "tt-frage" (list (car z) (cdr z))) T)
(ssg-start (ssg-text "tt-ersetzen-titel") nil)
(setq z (ssg-tt-ersetzen-ss ss suche ersatz teil-p nil))
(ssg-end)
(prompt (ssg-textf "tt-ergebnis" (list (car z) (cdr z)))))
(t (prompt (ssg-text "tt-abgebrochen")))
)
)
)
)
)
(princ)
)
;; ------------------------------------------------------------
;; PARALLEL BESCHRIFTEN
;; ------------------------------------------------------------
;; Winkel der Kurve (Linie, Polylinie, Bogen, ...) am Punkt pt (WKS).
;; Rueckgabe: Winkel in Bogenmass oder nil, wenn nicht ermittelbar.
(defun ssg-tt-kurven-winkel (ent pt / obj cp param deriv)
(setq obj (vlax-ename->vla-object ent))
(setq cp (vl-catch-all-apply 'vlax-curve-getclosestpointto (list obj pt)))
(if (or (vl-catch-all-error-p cp) (null cp))
nil
(progn
(setq param (vl-catch-all-apply 'vlax-curve-getparamatpoint (list obj cp)))
(if (or (vl-catch-all-error-p param) (null param))
nil
(progn
(setq deriv (vl-catch-all-apply 'vlax-curve-getfirstderiv (list obj param)))
(if (or (vl-catch-all-error-p deriv) (null deriv))
nil
(list (atan (cadr deriv) (car deriv)) cp)
)
)
)
)
)
)
;; TEXT erzeugen (unten mittig, Gruppe 73 = 1 damit Gruppe 11 gilt)
(defun ssg-tt-text-machen (p hoehe string winkel)
(entmake (list '(0 . "TEXT")
(cons 8 (getvar "CLAYER"))
(cons 7 (getvar "TEXTSTYLE"))
(cons 10 p)
(cons 11 p)
(cons 40 hoehe)
(cons 1 string)
(cons 50 winkel)
(cons 72 1)
(cons 73 1)))
)
(defun c:SSG_TEXT_PARALLEL ( / sel info a ar p text)
(ssg-start (ssg-text "tt-parallel-titel") nil)
(if (or (null *ssg-tt-hoehe*) (<= *ssg-tt-hoehe* 0.0))
(setq *ssg-tt-hoehe* (if (> (getvar "TEXTSIZE") 0.0) (getvar "TEXTSIZE") 2.5))
)
(setq *ssg-tt-hoehe* (ssg-in-real (ssg-text "tt-hoehe") *ssg-tt-hoehe*))
(if (null *ssg-tt-abstand*)
(setq *ssg-tt-abstand* (* 0.5 *ssg-tt-hoehe*))
)
(setq *ssg-tt-abstand* (ssg-in-real (ssg-text "tt-abstand") *ssg-tt-abstand*))
(while (setq sel (entsel (ssg-text "tt-parallel-waehlen")))
(setq info (ssg-tt-kurven-winkel (car sel) (trans (cadr sel) 1 0)))
(if (null info)
(prompt (ssg-text "tt-parallel-keine-kurve"))
(progn
(setq a (car info)
ar (ssg-tt-lesbarer-winkel a)
p (ssg-tt-versetzt (cadr info) (+ ar (/ pi 2.0)) *ssg-tt-abstand*)
text (ssg-in-string (ssg-text "tt-text") *ssg-tt-text*))
(if (and text (/= text ""))
(progn
(setq *ssg-tt-text* text)
(if (not (ssg-tt-text-machen p *ssg-tt-hoehe* text ar))
(prompt (ssg-text "tt-parallel-fehler"))
)
)
)
)
)
)
(ssg-end)
(princ)
)
;; ------------------------------------------------------------
;; HOEHE / STIL AENDERN
;; ------------------------------------------------------------
(defun c:SSG_TEXT_HOEHE ( / ents hoehe n)
(prompt (ssg-text "tt-auswahl"))
(setq ents (ssg-tt-ss-liste (ssget '((0 . "TEXT,MTEXT"))) '("TEXT" "MTEXT")))
(if (null ents)
(prompt (ssg-text "tt-keine-objekte"))
(progn
(setq hoehe (ssg-in-real (ssg-text "tt-hoehe")
(if (> (getvar "TEXTSIZE") 0.0) (getvar "TEXTSIZE") nil)))
(if (or (null hoehe) (<= hoehe 0.0))
(prompt (ssg-text "tt-abgebrochen"))
(progn
(ssg-start (ssg-text "tt-hoehe-titel") nil)
(setq n 0)
(foreach ent ents
(if (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-height
(list (vlax-ename->vla-object ent) hoehe))))
(setq n (1+ n))
)
)
(ssg-end)
(prompt (ssg-textf "tt-geaendert" (list n)))
)
)
)
)
(princ)
)
(defun c:SSG_TEXT_STIL ( / ents stil n)
(prompt (ssg-text "tt-auswahl"))
(setq ents (ssg-tt-ss-liste (ssget '((0 . "TEXT,MTEXT"))) '("TEXT" "MTEXT")))
(if (null ents)
(prompt (ssg-text "tt-keine-objekte"))
(progn
(setq stil (ssg-in-string (ssg-text "tt-stil") (getvar "TEXTSTYLE")))
(cond
((or (null stil) (null (tblsearch "STYLE" stil)))
(prompt (ssg-textf "tt-stil-fehlt" (list (if stil stil "")))))
(t
(ssg-start (ssg-text "tt-stil-titel") nil)
(setq n 0)
(foreach ent ents
(if (not (vl-catch-all-error-p
(vl-catch-all-apply 'vla-put-stylename
(list (vlax-ename->vla-object ent) stil))))
(setq n (1+ n))
)
)
(ssg-end)
(prompt (ssg-textf "tt-geaendert" (list n))))
)
)
)
(princ)
)
(princ)