dxfmakros/Lisp/purge_blocks.lsp

;; ============================================================
;; purge_blocks.lsp
;; Entfernt in allen DWG-Dateien in data/ils die nicht
;; verwendeten Block-Definitionen und Layer (-PURGE Blocks/Layer).
;;
;; Ablauf je DWG:
;;   - Datei oeffnen (falls noetig)
;;   - Block- und Layer-Anzahl zaehlen
;;   - -PURGE Blocks und -PURGE Layer in einer Schleife ausfuehren,
;;     bis nichts mehr entfernt wird (verschachtelte Bloecke bzw.
;;     nur von entfernten Bloecken benutzte Layer werden erst nach
;;     dem ersten Durchlauf frei)
;;   - nur speichern, wenn sich die Anzahl verringert hat
;;   - schliessen (falls durch dieses Skript geoeffnet)
;;
;; Es werden AUSSCHLIESSLICH unbenutzte Bloecke und Layer entfernt.
;; Andere Objekttypen (Linientypen, Textstile, ...) bleiben
;; unangetastet.
;;
;; Voraussetzung: DXFM_DATA ist gesetzt (siehe bin/setenv.bat).
;;
;; Aufruf in BricsCAD:
;;   (load "C:/.../Lisp/purge_blocks.lsp")
;;   ILS_BLOCK_PURGE
;; ============================================================

(vl-load-com)

;; ------------------------------------------------------------
;; Bereits offenes Dokument mit gegebenem Pfad suchen (oder nil)
;; ------------------------------------------------------------
(defun pb-find-open-doc (dwg-pfad / docs anzahl i doc full treffer)
  (setq docs   (vla-get-Documents (vlax-get-acad-object))
        anzahl (vla-get-Count docs)
        i      0
        treffer nil
        dwg-pfad (strcase (vl-string-translate "\\" "/" dwg-pfad))
  )
  (while (and (< i anzahl) (not treffer))
    (setq doc (vla-item docs i))
    (setq full (strcase (vl-string-translate "\\" "/" (vla-get-FullName doc))))
    (if (= full dwg-pfad) (setq treffer doc))
    (setq i (1+ i))
  )
  treffer
)

;; ------------------------------------------------------------
;; Anzahl aller Eintraege einer Symboltabelle zaehlen
;; (z.B. "BLOCK" inkl. Model/Paper-Space/anonyme, "LAYER").
;; ------------------------------------------------------------
(defun pb-count-table (tabelle / n def)
  (setq n 0 def (tblnext tabelle T))
  (while def
    (setq n (1+ n))
    (setq def (tblnext tabelle))
  )
  n
)

;; ------------------------------------------------------------
;; Im aktiven Dokument unbenutzte Bloecke UND Layer purgen, bis
;; stabil. Erst Bloecke, dann Layer (ein nur von einem entfernten
;; Block benutzter Layer wird erst danach frei) - daher Schleife
;; ueber beide Typen, bis sich nichts mehr aendert.
;; ------------------------------------------------------------
(defun pb-purge-current-doc ( / vorher aktuell durchlauf max-durchlauf)
  (setq vorher       (+ (pb-count-table "BLOCK") (pb-count-table "LAYER"))
        aktuell       vorher
        durchlauf     1
        max-durchlauf 20
  )
  (while (and (<= durchlauf max-durchlauf)
              (progn
                (command "_.-PURGE" "_B" "*" "_N")   ; unbenutzte Bloecke
                (command "_.-PURGE" "_LA" "*" "_N")  ; unbenutzte Layer
                (setq aktuell (+ (pb-count-table "BLOCK") (pb-count-table "LAYER")))
                ;; weiter, solange noch etwas entfernt wurde
                (if (< aktuell vorher)
                  (progn (setq vorher aktuell) T)
                  nil
                )
              )
         )
    (setq durchlauf (1+ durchlauf))
  )
  aktuell
)

;; ------------------------------------------------------------
;; Eine DWG-Datei oeffnen (falls noetig), purgen, speichern (nur
;; bei Aenderung) und schliessen (falls hier geoeffnet).
;; Rueckgabe: ('ok blk-entfernt . lay-entfernt) oder ('fehler . meldung)
;; ------------------------------------------------------------
(defun pb-purge-dwg (dwg-pfad / bereits-offen blk-vor blk-nach lay-vor lay-nach
                      blk-entfernt lay-entfernt fehler)
  (setq bereits-offen (pb-find-open-doc dwg-pfad))
  (setq blk-entfernt 0 lay-entfernt 0)
  (setq fehler
    (vl-catch-all-apply
      (function
        (lambda ()
          (if bereits-offen
            (vlax-put-property (vlax-get-acad-object) 'ActiveDocument bereits-offen)
            (command "_.OPEN" dwg-pfad)
          )
          (setq blk-vor (pb-count-table "BLOCK")
                lay-vor (pb-count-table "LAYER")
          )
          (pb-purge-current-doc)
          (setq blk-nach     (pb-count-table "BLOCK")
                lay-nach     (pb-count-table "LAYER")
                blk-entfernt (- blk-vor blk-nach)
                lay-entfernt (- lay-vor lay-nach)
          )
          (if (or (> blk-entfernt 0) (> lay-entfernt 0))
            (command "_.QSAVE")
          )
          (if (not bereits-offen) (command "_.CLOSE"))
        )
      )
      nil
    )
  )
  (if (vl-catch-all-error-p fehler)
    (cons 'fehler (vl-catch-all-error-message fehler))
    (list 'ok blk-entfernt lay-entfernt)
  )
)

;; ------------------------------------------------------------
;; Hauptbefehl - verarbeitet DXFM_DATA/ils
;; ------------------------------------------------------------
(defun c:ILS_BLOCK_PURGE ( / data-dir dwg-dir dateien datei dwg-pfad ergebnis
                            orig-doc anzahl-ok anzahl-fehler summe-blk summe-lay
                            blk lay fehler-liste geaendert-liste)
  (setq data-dir (getenv "DXFM_DATA"))
  (if (not data-dir)
    (progn
      (alert "DXFM_DATA ist nicht gesetzt.\nBitte zuerst bin/setenv.bat ausfuehren.")
      (exit)
    )
  )
  (setq data-dir (vl-string-translate "\\" "/" data-dir)
        dwg-dir  (vl-string-right-trim "/" (strcat data-dir "/ils"))
  )

  (if (not (findfile dwg-dir))
    (progn
      (princ (strcat "\n[BLOCK-PURGE] Verzeichnis nicht gefunden: " dwg-dir))
      (exit)
    )
  )

  (setq dateien (vl-directory-files dwg-dir "*.dwg" 1))
  (if (not dateien)
    (progn
      (princ (strcat "\n[BLOCK-PURGE] Keine DWG-Dateien in: " dwg-dir))
      (exit)
    )
  )

  (setq orig-doc        (vla-get-ActiveDocument (vlax-get-acad-object))
        anzahl-ok       0
        anzahl-fehler   0
        summe-blk       0
        summe-lay       0
        fehler-liste    nil
        geaendert-liste nil
  )
  (foreach datei dateien
    (setq dwg-pfad (strcat dwg-dir "/" datei))
    (princ (strcat "\n[BLOCK-PURGE] Bearbeite " datei " ..."))
    (setq ergebnis (pb-purge-dwg dwg-pfad))
    (if (equal (car ergebnis) 'fehler)
      (progn
        (princ (strcat "\n[BLOCK-PURGE] FEHLER bei " datei ": " (cdr ergebnis)))
        (setq anzahl-fehler (1+ anzahl-fehler))
        (setq fehler-liste (cons datei fehler-liste))
      )
      (progn
        (setq anzahl-ok (1+ anzahl-ok)
              blk       (nth 1 ergebnis)
              lay       (nth 2 ergebnis)
        )
        (if (or (> blk 0) (> lay 0))
          (progn
            (princ (strcat " " (itoa blk) " Block(e), " (itoa lay) " Layer entfernt, gespeichert."))
            (setq summe-blk       (+ summe-blk blk)
                  summe-lay       (+ summe-lay lay)
            )
            (setq geaendert-liste (cons (strcat datei " (B:" (itoa blk) " L:" (itoa lay) ")") geaendert-liste))
          )
          (princ " keine unbenutzten Bloecke/Layer.")
        )
      )
    )
  )
  (vlax-put-property (vlax-get-acad-object) 'ActiveDocument orig-doc)

  (princ (strcat "\n[BLOCK-PURGE] Fertig: " (itoa anzahl-ok) " Datei(en) bearbeitet, "
                 (itoa summe-blk) " Block(e), "
                 (itoa summe-lay) " Layer entfernt, "
                 (itoa anzahl-fehler) " Fehler."))
  (if geaendert-liste
    (progn
      (princ "\n[BLOCK-PURGE] Geaenderte Dateien:")
      (foreach datei (reverse geaendert-liste)
        (princ (strcat "\n    - " datei))
      )
    )
  )
  (if fehler-liste
    (progn
      (princ "\n[BLOCK-PURGE] WARNUNG: Fehler bei:")
      (foreach datei (reverse fehler-liste)
        (princ (strcat "\n    - " datei))
      )
    )
  )
  (princ)
)

(princ "\npurge_blocks.lsp geladen. Befehl: ILS_BLOCK_PURGE")
(princ)