;;; ==================================================================
;;;  BLK-IIC-EN.LSP  -  working on BLOCKS in bulk
;;;  Institute of Information Technology in Civil Engineering (IIC)
;;;  Hanoi University of Civil Engineering
;;;  https://iic.huce.edu.vn  -  Tel: 0989 427 809
;;; ------------------------------------------------------------------
;;;  Four commands:
;;;    BKD     count blocks by name and print a table
;;;    BKM     colour EVERY insertion of one block
;;;    BKT     rename a block; every insertion follows
;;;    BKP     explode every insertion of ONE block, leaving the rest alone
;;;
;;;  Why this file is needed: AutoCAD has BCOUNT for counting blocks, but
;;;  it lives in Express Tools and not every installation has them. For
;;;  colouring or exploding one kind of block there is no command at all:
;;;  QSELECT can select by block name, but only through a dialog and only
;;;  one condition at a time.
;;;
;;;  FOUR THINGS TO KNOW BEFORE RUNNING:
;;;    1. BKD counts INSERTIONS, not definitions. A block placed 40 times
;;;       counts 40. An insertion nested inside another block is NOT
;;;       counted - only the outermost level is. Autodesk's own BCOUNT
;;;       behaves the same way.
;;;    2. BKM sets the colour of the INSERTION, not of the linework inside
;;;       it. Anything inside the definition with a HARD colour (not
;;;       ByBlock) keeps its old colour however often you run this. That
;;;       is the familiar "I changed the colour and nothing happened".
;;;    3. BKT renames the block definition. Any drawing xrefing this one,
;;;       and any schedule looking the old name up, breaks.
;;;    4. BKP explodes insertions; a block placed with X and Y scales that
;;;       differ still explodes, but circles inside it become ELLIPSES.
;;;       There is no way round that.
;;;  Every command PRINTS how many insertions it touched, so the result
;;;  can be checked.
;;;
;;;  Command names were checked before being chosen: the acad.pgp alias
;;;  file of the 2027 release has no BKD, BKM, BKT or BKP.
;;;
;;;  To load: type APPLOAD, pick this file, click Load.
;;;  Saved as UTF-8. If you edit it in Notepad, save it back as UTF-8.
;;; ==================================================================

(vl-load-com)

;;; pad right / pad left to width n
(defun iic-pad (s n) (while (< (strlen s) n) (setq s (strcat s " "))) s)
(defun iic-rpad (s n) (while (< (strlen s) n) (setq s (strcat " " s))) s)

;;; ------------------------------------------------------------------
;;;  The real name of an insertion. A dynamic block reports a temporary
;;;  name like "*U123", so EffectiveName has to be asked for.
;;; ------------------------------------------------------------------
(defun iic-name (e / o tn)
  ;; Do NOT name a local variable "t": in AutoLISP T is the constant for
  ;; true, and binding it raises "; error: incorrect object to bind: T".
  (setq o (vlax-ename->vla-object e))
  (setq tn (vl-catch-all-apply 'vlax-get (list o 'EffectiveName)))
  (if (or (vl-catch-all-error-p tn) (null tn))
    (cdr (assoc 2 (entget e)))
    tn
  )
)

;;; ------------------------------------------------------------------
;;;  BKD - count blocks by name
;;; ------------------------------------------------------------------
(defun c:BKD (/ ss i e nm tbl o total)
  (princ "\nSelect an area to count (Enter for the whole drawing): ")
  (setq ss (ssget '((0 . "INSERT"))))
  (if (null ss) (setq ss (ssget "_X" '((0 . "INSERT")))))
  (if ss
    (progn
      (setq tbl nil i 0)
      (while (< i (sslength ss))
        (setq e  (ssname ss i)
              nm (iic-name e)
              o  (assoc nm tbl))
        (if o
          (setq tbl (subst (cons nm (1+ (cdr o))) o tbl))
          (setq tbl (cons (cons nm 1) tbl))
        )
        (setq i (1+ i))
      )
      (setq tbl (vl-sort tbl (function (lambda (a b) (> (cdr a) (cdr b))))))
      (setq total 0)
      (princ "\n")
      (princ "\n  Block name                        Insertions")
      (princ "\n  ---------------------------------------------")
      (foreach o tbl
        (setq total (+ total (cdr o)))
        (princ (strcat "\n  " (iic-pad (car o) 32) (iic-rpad (itoa (cdr o)) 11)))
      )
      (princ "\n  ---------------------------------------------")
      (princ (strcat "\n  Total insertions" (iic-rpad (itoa total) 29)))
      (princ (strcat "\n  Distinct block names" (iic-rpad (itoa (length tbl)) 25)))
      (princ "\n")
    )
    (princ "\nNo block insertions found.")
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  BKM - colour every insertion of one block
;;; ------------------------------------------------------------------
(defun c:BKM (/ nm col ss i e n)
  (setq nm (getstring T "\nBlock name to colour: "))
  (if (= nm "") (progn (princ "\nNo name given.") (exit)))
  (setq col (getint "\nColour number (1 red, 2 yellow, 3 green, 4 cyan, 5 blue, 7 white): "))
  (if (null col) (progn (princ "\nNo colour given.") (exit)))
  (setq ss (ssget "_X" '((0 . "INSERT"))) i 0 n 0)
  (if ss
    (progn
      (while (< i (sslength ss))
        (setq e (ssname ss i))
        (if (= (strcase (iic-name e)) (strcase nm))
          (progn
            (entmod (append (vl-remove-if (function (lambda (x) (= (car x) 62)))
                                          (entget e))
                            (list (cons 62 col))))
            (setq n (1+ n))
          )
        )
        (setq i (1+ i))
      )
      (princ (strcat "\nColoured " (itoa n) " insertion(s) of block \"" nm "\"."))
      (if (= n 0)
        (princ "\nNo insertion of that name. Run BKD to see the list of names.")
        (princ "\nNote: linework inside the block with a hard colour does not follow.")
      )
    )
    (princ "\nThe drawing holds no blocks.")
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  BKT - rename a block
;;; ------------------------------------------------------------------
(defun c:BKT (/ old new bl r)
  (setq old (getstring T "\nCurrent block name: "))
  (setq new (getstring T "\nNew name: "))
  (if (or (= old "") (= new ""))
    (progn (princ "\nA name is missing.") (exit))
  )
  (setq bl (tblobjname "BLOCK" old))
  (if (null bl)
    (princ (strcat "\nNo block named \"" old "\". Run BKD to see the list."))
    (if (tblobjname "BLOCK" new)
      (princ (strcat "\nA block named \"" new "\" already exists. Pick another name."))
      (progn
        (setq r (vl-catch-all-apply
                  'vla-put-Name
                  (list (vla-item (vla-get-Blocks
                                    (vla-get-ActiveDocument
                                      (vlax-get-acad-object))) old) new)))
        (if (vl-catch-all-error-p r)
          (princ (strcat "\nCould not rename: " (vl-catch-all-error-message r)))
          (progn
            (princ (strcat "\nRenamed \"" old "\" to \"" new "\"."))
            (princ "\nNote: any schedule looking the old name up will no longer find it.")
          )
        )
      )
    )
  )
  (princ)
)

;;; ------------------------------------------------------------------
;;;  BKP - explode every insertion of ONE block
;;; ------------------------------------------------------------------
(defun c:BKP (/ nm ss i e ds ds2 n x)
  (setq nm (getstring T "\nBlock name to explode: "))
  (if (= nm "") (progn (princ "\nNo name given.") (exit)))
  (setq ss (ssget "_X" '((0 . "INSERT"))) i 0 ds (ssadd))
  (if ss
    (progn
      (while (< i (sslength ss))
        (setq e (ssname ss i))
        (if (= (strcase (iic-name e)) (strcase nm))
          (setq ds (ssadd e ds))
        )
        (setq i (1+ i))
      )
      (setq n (sslength ds))
      (if (= n 0)
        (princ (strcat "\nNo insertion named \"" nm "\"."))
        (progn
          ;; Explode them ONE AT A TIME. Handing the whole selection set to
          ;; (command "_.EXPLODE" ds) explodes exactly ONE of them and then
          ;; stops - measured on the 2027 release: five insertions selected,
          ;; one new object produced. Collect the enames into a list FIRST,
          ;; because exploding removes them from the drawing.
          (setq i 0 ds2 nil)
          (while (< i n)
            (setq ds2 (cons (ssname ds i) ds2) i (1+ i))
          )
          (foreach x ds2 (command "_.EXPLODE" x))
          (princ (strcat "\nExploded " (itoa n) " insertion(s) of block \"" nm "\"."))
          (princ "\nNote: circles inside a block placed at uneven scales become ellipses.")
        )
      )
    )
    (princ "\nThe drawing holds no blocks.")
  )
  (princ)
)

(princ "\nBLK-IIC-EN loaded. Commands: BKD (count), BKM (colour), BKT (rename), BKP (explode).")
(princ)