dxfmakros/Lisp/ssg_blocktools.lsp

;; ============================================================
;; SSG_BLOCKTOOLS.LSP - Block-Werkzeuge fuer die aktuelle Zeichnung
;;
;; Ursprung: ACADSST/MENU/TOOLS.LSP (BLKANZAHL, BLKENTF), DINGEN2
;; (g-bli) und ssg.lsp (suchen-aendern) - neu geschrieben im ssg-Stil
;; (Undo-Gruppe, i18n, Ja/Nein-Rueckfrage, keine Globals).
;;
;; Befehle:
;;   SSG_BLOCK_COUNT     Einfuegungen zaehlen (ein Block, Namensmuster
;;                       oder Statistik aller Bloecke)
;;   SSG_BLOCK_DELETE    Alle Einfuegungen eines Blocks/Namensmusters
;;                       loeschen (mit Rueckfrage)
;;   SSG_ATTR_ERSETZEN   Attributwerte zeichnungsweit oder in einer
;;                       Auswahl suchen und ersetzen (mit Vorschau)
;;
;; Blocknamen werden ueber den WIRKSAMEN Namen verglichen (dynamische
;; Bloecke: EffectiveName statt "*U12"). Muster arbeiten mit wcmatch
;; (Platzhalter * ? #, ohne Beachtung der Gross-/Kleinschreibung).
;; Es wird nur der aktuelle Layout-Reiter (Modell ODER Papierbereich)
;; durchsucht.
;;
;; Setzt ssg_core.lsp, ssg_lang.lsp und ssg_input.lsp voraus.
;; ============================================================

(vl-load-com)

;; ------------------------------------------------------------
;; REINE HILFSFUNKTIONEN (in test_unit getestet)
;; ------------------------------------------------------------

;; T, wenn name auf das wcmatch-Muster passt (ohne Gross-/Kleinschreibung).
;; muster nil oder "" -> alle Namen passen.
(defun ssg-bt-name-passt-p (name muster)
  (if (or (null muster) (= muster ""))
    T
    (if (wcmatch (strcase name) (strcase muster)) T nil)
  )
)

;; Liste von Namen -> Alist ((NAME . ANZAHL) ...), alphabetisch sortiert
;; (ohne Beachtung der Gross-/Kleinschreibung).
(defun ssg-bt-zaehle-namen (namen / alist eintrag)
  (foreach name namen
    (setq eintrag (assoc name alist))
    (if eintrag
      (setq alist (subst (cons name (1+ (cdr eintrag))) eintrag alist))
      (setq alist (cons (cons name 1) alist))
    )
  )
  (vl-sort alist '(lambda (a b) (< (strcase (car a)) (strcase (car b)))))
)

;; Sonderzeichen eines Blocknamens fuer wcmatch maskieren (Backquote), damit
;; ein per Pick gewaehlter Name nur sich selbst trifft.
(defun ssg-bt-muster-escape (name / res i c)
  (setq res "" i 1)
  (while (<= i (strlen name))
    (setq c (substr name i 1))
    (if (vl-string-search c "#@.*?~[],`")
      (setq res (strcat res "`"))
    )
    (setq res (strcat res c)
          i   (1+ i))
  )
  res
)

;; Muster ohne Maskier-Backquotes (fuer Meldungen)
(defun ssg-bt-muster-anzeige (muster)
  (ssg-str-replace-all "" "`" muster)
)

;; Neuer Attributwert oder nil, wenn der Wert unveraendert bleibt.
;; teil-p = T  : suche wird als Teilstring ueberall ersetzt
;; teil-p = nil: nur ersetzen, wenn der GESAMTE Wert gleich suche ist
;; Leere suche aendert nichts. Gross-/Kleinschreibung wird beachtet.
(defun ssg-bt-wert-neu (wert suche ersatz teil-p)
  (cond
    ((or (null suche) (= suche "") (null wert)) nil)
    (teil-p
      (if (vl-string-search suche wert)
        (ssg-str-replace-all ersatz suche wert)
        nil
      )
    )
    ((= wert suche) ersatz)
    (t nil)
  )
)

;; ------------------------------------------------------------
;; ZEICHNUNGSZUGRIFF
;; ------------------------------------------------------------

;; Wirksamer Blockname einer Einfuegung (dynamische Bloecke beachten)
(defun ssg-bt-effname (ent / res)
  (setq res (vl-catch-all-apply 'vla-get-effectivename
              (list (vlax-ename->vla-object ent))))
  (if (vl-catch-all-error-p res)
    (cdr (assoc 2 (entget ent)))
    res
  )
)

;; T, wenn der Layer der Entity gesperrt ist
(defun ssg-bt-layer-gesperrt-p (ent / lay)
  (setq lay (tblsearch "LAYER" (cdr (assoc 8 (entget ent)))))
  (and lay (= 4 (logand 4 (cdr (assoc 70 lay)))))
)

;; Alle Einfuegungen im aktuellen Layout, optional gefiltert nach Namensmuster.
;; Rueckgabe: Liste von Entity-Namen (kann leer sein).
(defun ssg-bt-inserts (muster / ss i ent res)
  (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 410 (getvar "CTAB")))))
  (if ss
    (progn
      (setq i 0)
      (while (setq ent (ssname ss i))
        (if (ssg-bt-name-passt-p (ssg-bt-effname ent) muster)
          (setq res (cons ent res))
        )
        (setq i (1+ i))
      )
    )
  )
  (reverse res)
)

;; Statistik: ((NAME . ANZAHL) ...) fuer alle Einfuegungen passend zum Muster
(defun ssg-bt-statistik (muster)
  (ssg-bt-zaehle-namen (mapcar 'ssg-bt-effname (ssg-bt-inserts muster)))
)

;; Block per Pick oder Namensmuster waehlen.
;; Rueckgabe: Namensmuster (String) oder nil bei Enter ("alle").
(defun ssg-bt-muster-waehlen (text / sel ed)
  (initget "Name")
  (setq sel (entsel text))
  (cond
    ((null sel) nil)
    ((= (type sel) 'STR)
      (setq sel (getstring T (ssg-text "bt-prompt-muster")))
      (if (= sel "") nil sel)
    )
    (t
      (setq ed (entget (car sel)))
      (if (= (cdr (assoc 0 ed)) "INSERT")
        (ssg-bt-muster-escape (ssg-bt-effname (car sel)))
        (progn (prompt (ssg-text "bt-kein-block")) nil)
      )
    )
  )
)

;; Attribute EINER Einfuegung ersetzen (oder nur zaehlen, wenn probe-p).
;; tag = wcmatch-Muster fuer den Attribut-Tag ("*" = alle).
;; Rueckgabe: Anzahl betroffener Attribute.
(defun ssg-bt-attr-ersetzen-ent (ent tag suche ersatz teil-p probe-p
                                 / e ed neu n)
  (setq n 0
        e (entnext ent))
  (while (and e
              (= "ATTRIB" (cdr (assoc 0 (setq ed (entget e))))))
    (if (and (ssg-bt-name-passt-p (cdr (assoc 2 ed)) tag)
             (setq neu (ssg-bt-wert-neu (cdr (assoc 1 ed)) suche ersatz teil-p)))
      (progn
        (setq n (1+ n))
        (if (not probe-p)
          (entmod (subst (cons 1 neu) (assoc 1 ed) ed))
        )
      )
    )
    (setq e (entnext e))
  )
  (if (and (> n 0) (not probe-p)) (entupd ent))
  n
)

;; Attribute einer Liste von Einfuegungen ersetzen. Rueckgabe: Anzahl.
(defun ssg-bt-attr-ersetzen-liste (ents tag suche ersatz teil-p probe-p / n)
  (setq n 0)
  (foreach ent ents
    (setq n (+ n (ssg-bt-attr-ersetzen-ent ent tag suche ersatz teil-p probe-p)))
  )
  n
)

;; Auswahlsatz -> Liste von Entity-Namen (nur INSERT)
(defun ssg-bt-ss-inserts (ss / i ent res)
  (if ss
    (progn
      (setq i 0)
      (while (setq ent (ssname ss i))
        (if (= (cdr (assoc 0 (entget ent))) "INSERT")
          (setq res (cons ent res))
        )
        (setq i (1+ i))
      )
    )
  )
  (reverse res)
)

;; ------------------------------------------------------------
;; BEFEHLE
;; ------------------------------------------------------------

(defun c:SSG_BLOCK_COUNT ( / muster stat summe)
  (setq muster (ssg-bt-muster-waehlen (ssg-text "bt-prompt-waehlen-count")))
  (setq stat (ssg-bt-statistik muster))
  (cond
    ((null stat)
      (prompt (if muster
                (ssg-textf "bt-count-keine" (list (ssg-bt-muster-anzeige muster)))
                (ssg-text "bt-count-keine-alle")))
    )
    ((and muster (null (cdr stat)))
      (prompt (ssg-textf "bt-count-ergebnis" (list (cdar stat) (caar stat))))
    )
    (t
      (setq summe 0)
      (foreach z stat
        (prompt (ssg-textf "bt-count-zeile" (list (car z) (cdr z))))
        (setq summe (+ summe (cdr z)))
      )
      (prompt (ssg-textf "bt-count-summe" (list summe (length stat))))
    )
  )
  (princ)
)

(defun c:SSG_BLOCK_DELETE ( / muster ents frei gesperrt n)
  (setq muster (ssg-bt-muster-waehlen (ssg-text "bt-prompt-waehlen-delete")))
  (if (null muster)
    (prompt (ssg-text "bt-delete-kein-muster"))
    (progn
      (setq ents (ssg-bt-inserts muster))
      (foreach ent ents
        (if (ssg-bt-layer-gesperrt-p ent)
          (setq gesperrt (cons ent gesperrt))
          (setq frei (cons ent frei))
        )
      )
      (cond
        ((null ents)
          (prompt (ssg-textf "bt-count-keine" (list (ssg-bt-muster-anzeige muster)))))
        ((null frei)
          (prompt (ssg-textf "bt-delete-alle-gesperrt" (list (length gesperrt)))))
        ((ssg-in-yesno (ssg-textf "bt-delete-frage" (list (length frei) (ssg-bt-muster-anzeige muster))) nil)
          (ssg-start (ssg-text "bt-delete-titel") nil)
          (setq n 0)
          (foreach ent frei
            (if (entdel ent) (setq n (1+ n)))
          )
          (ssg-end)
          (prompt (ssg-textf "bt-delete-ergebnis" (list n)))
          (if gesperrt
            (prompt (ssg-textf "bt-delete-gesperrt" (list (length gesperrt)))))
        )
        (t (prompt (ssg-text "bt-abgebrochen")))
      )
    )
  )
  (princ)
)

(defun c:SSG_ATTR_ERSETZEN ( / k-bereich k-modus bereich ents muster tag suche ersatz modus teil-p n)
  (setq k-bereich (ssg-text "in-keys-bereich")
        k-modus   (ssg-text "in-keys-modus")
        bereich   (ssg-in-keyword (ssg-text "bt-attr-bereich") k-bereich
                    (ssg-in-first-word k-bereich)))
  (if (= bereich (ssg-in-first-word k-bereich))
    (progn
      (setq muster (ssg-in-string (ssg-text "bt-attr-muster") "*"))
      (setq ents (ssg-bt-inserts muster))
    )
    (progn
      (prompt (ssg-text "bt-attr-auswahl"))
      (setq ents (ssg-bt-ss-inserts (ssget '((0 . "INSERT")))))
    )
  )
  (cond
    ((null ents) (prompt (ssg-text "bt-attr-keine-bloecke")))
    (t
      (setq tag   (ssg-in-string (ssg-text "bt-attr-tag") "*")
            suche (ssg-in-string (ssg-text "bt-attr-suche") nil))
      (if (or (null suche) (= suche ""))
        (prompt (ssg-text "bt-abgebrochen"))
        (progn
          (setq ersatz (ssg-in-string (ssg-text "bt-attr-ersatz") "")
                modus  (ssg-in-keyword (ssg-text "bt-attr-modus") k-modus
                         (ssg-in-first-word k-modus))
                teil-p (= modus (ssg-in-first-word k-modus)))
          (setq n (ssg-bt-attr-ersetzen-liste ents tag suche ersatz teil-p T))
          (cond
            ((= n 0) (prompt (ssg-text "bt-attr-nichts")))
            ((ssg-in-yesno (ssg-textf "bt-attr-frage" (list n (length ents))) T)
              (ssg-start (ssg-text "bt-attr-titel") nil)
              (setq n (ssg-bt-attr-ersetzen-liste ents tag suche ersatz teil-p nil))
              (ssg-end)
              (prompt (ssg-textf "bt-attr-ergebnis" (list n))))
            (t (prompt (ssg-text "bt-abgebrochen")))
          )
        )
      )
    )
  )
  (princ)
)

(princ)