;;; ---------------------------------------------------------------------------
;;; TagTint.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Sets the colour of chosen attribute TAGS independently of the blocks that
;;; contain them.
;;;
;;; Select some attributed blocks and a dialog lists every distinct tag found
;;; across them. Tick the tags you want, choose a colour, and only those
;;; attributes change - across every selected block at once.
;;;
;;; The typical use is making one field stand out consistently: every DOOR_REF
;;; on the sheet turns red, while every other attribute in the same blocks is
;;; left exactly as it was.
;;;
;;; ABOUT THE DIALOG
;;; The DCL is written out to a temporary file at run time, loaded, and deleted
;;; immediately afterwards. That is deliberate - it keeps this routine a single
;;; self-contained file with no companion .dcl to deploy alongside it or lose.
;;; The dialog name "tagtint" appears in three places that must always agree:
;;; the DCL text itself, the new_dialog call, and nowhere else. If you rename
;;; it, rename it in both.
;;;
;;; CONSTANT ATTRIBUTES ARE INCLUDED
;;; GetAttributes returns only variable attributes, so GetConstantAttributes is
;;; called as well and the two lists joined. Without that, constant attributes
;;; would be invisible to this routine even though they are plainly visible in
;;; the drawing.
;;;
;;;   TAGTINT  - recolour selected attribute tags
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; ---------------------------------------------------------------------------
;; Last colour chosen, remembered between runs so repeated use does not mean
;; re-picking the same colour every time. Global by necessity: it must outlive
;; the command that sets it. 1 is red, a sensible first-time default.
;; ---------------------------------------------------------------------------
(or *TagTint:Colour* (setq *TagTint:Colour* 1))

;; ---------------------------------------------------------------------------
;; TagTint:Unique
;; ---------------------------------------------------------------------------
;; Returns the supplied list with duplicates removed, preserving first-seen
;; order. Used to reduce the full list of tags found - which will contain one
;; entry per attribute per block - down to the distinct tag names.
;; ---------------------------------------------------------------------------
(defun TagTint:Unique ( lst )
    (if lst
        (cons (car lst)
              (TagTint:Unique (vl-remove (car lst) (cdr lst)))
        )
    )
)

;; ---------------------------------------------------------------------------
;; TagTint:Swatch
;; ---------------------------------------------------------------------------
;; Paints the colour preview tile.
;;
;; Must remain callable by name from the action_tile strings below, which are
;; evaluated as text at dialog run time - so renaming this function means
;; editing those strings to match.
;;
;; key - [str] the image tile key
;; col - [int] AutoCAD colour index to fill it with
;; ---------------------------------------------------------------------------
(defun TagTint:Swatch ( key col )
    (start_image key)
    (fill_image 0 0 (dimx_tile key) (dimy_tile key) col)
    (end_image)
)

;; ---------------------------------------------------------------------------
;; TagTint:Dialog
;; ---------------------------------------------------------------------------
;; Displays the tag list and colour picker. Returns the list of chosen tag
;; names, or nil if the user cancelled.
;;
;; The dialog file is created, loaded, used, unloaded and deleted here, so the
;; temporary file never outlives the call - including when the user cancels.
;;
;; tags - [list] distinct tag names to offer
;; ---------------------------------------------------------------------------
(defun TagTint:Dialog ( tags / file tmp dch choice )

    (cond
        ;; Build and load the dialog. Every step is chained through and so a
        ;; failure at any point - disk full, no write permission on the temp
        ;; folder, a DCL syntax error - drops straight to the cleanup below
        ;; rather than leaving a half-open dialog handle.
        (   (not
                (and
                    (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
                    (write-line
                        (strcat
                            "tagtint : dialog { label = \"Attribute Tag Colour\"; spacer;"
                            "  : list_box { label = \"Select Tags\"; key = \"tags\"; fixed_width = false; multiple_select = true; alignment = centered; }"
                            "  : boxed_column { label = \"Colour\";"
                            "    : row { spacer;"
                            "      : button { key = \"but\"; width = 12; fixed_width = true; label = \"Select Colour\"; }"
                            "      : image_button { key = \"img\"; alignment = centered; height = 1.5; width = 4.0;"
                            "                       fixed_width = true; fixed_height = true; color = 2; }"
                            "      spacer;"
                            "    }"
                            "    spacer;"
                            "  }"
                            "  spacer; ok_cancel;"
                            "}"
                        )
                        file
                    )
                    (not (close file))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "tagtint" dch)
                )
            )
            (princ "\nThe dialog could not be created.")
        )

        (   t
            (start_list "tags")
            (mapcar 'add_list tags)
            (end_list)

            ;; Pre-select the first tag so OK is never meaningless.
            (setq choice (set_tile "tags" "0"))
            (TagTint:Swatch "img" *TagTint:Colour*)

            ;; Both the button and the swatch open the colour dialog. The cond
            ;; keeps the previous colour if the user cancels the picker, rather
            ;; than dropping to nil and failing later.
            (action_tile "img"  "(TagTint:Swatch \"img\" (setq *TagTint:Colour* (cond ((acad_colordlg *TagTint:Colour*)) (*TagTint:Colour*))))")
            (action_tile "but"  "(TagTint:Swatch \"img\" (setq *TagTint:Colour* (cond ((acad_colordlg *TagTint:Colour*)) (*TagTint:Colour*))))")
            (action_tile "tags" "(setq choice $value)")

            ;; A multi-select list box returns its selection as a string of
            ;; space-separated indices, e.g. "0 2 5". Wrapping that in brackets
            ;; and reading it converts it to a list of integers, which are then
            ;; mapped back to the tag names they refer to.
            (setq choice
                (if (= 1 (start_dialog))
                    (mapcar (function (lambda ( n ) (nth n tags)))
                            (read (strcat "(" choice ")"))
                    )
                )
            )
        )
    )

    ;; Cleanup runs on every path, successful or not.
    (if (and dch (< 0 dch))
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )

    choice
)

;; ---------------------------------------------------------------------------
;; c:TAGTINT  -  main routine
;; ---------------------------------------------------------------------------
(defun c:TAGTINT ( / *error* vars vals doc sel pairs chosen pair count )

    (setq vars '("CMDECHO")
          vals (mapcar 'getvar vars)
    )

    (defun TagTint:Restore ( )
        (mapcar 'setvar vars vals)
        (while (= 8 (logand 8 (getvar 'undoctl)))
            (command "_.UNDO" "_End")
            (vl-catch-all-apply '(lambda ( ) (*pop-error-mode*)) '())
        )
        (princ)
    )

    (defun *error* ( msg )
        (TagTint:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** TAGTINT error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)
    (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

    (if
        (and
            ;; (66 . 1) restricts the selection to block references that
            ;; actually carry attributes; "_:L" excludes locked layers.
            (ssget "_:L" '((0 . "INSERT") (66 . 1)))
            (progn
                ;; Collect every attribute as (tagName . attributeObject), so
                ;; the tags can be listed for the user while the objects
                ;; themselves remain available to recolour afterwards.
                (vlax-for obj (setq sel (vla-get-ActiveSelectionSet doc))
                    (foreach att
                        (append (vlax-invoke obj 'GetAttributes)
                                (vlax-invoke obj 'GetConstantAttributes)
                        )
                        (setq pairs (cons (cons (vla-get-TagString att) att) pairs))
                    )
                )
                ;; The selection set object is released explicitly; ActiveX
                ;; selection sets persist in the document until deleted.
                (vla-delete sel)

                (setq chosen
                    (TagTint:Dialog
                        (acad_strlsort (TagTint:Unique (mapcar 'car pairs)))
                    )
                )
            )
        )
        (progn
            ;; AutoCAD 2015 and later refuse (command) inside an *error* handler
            ;; unless the routine says up front that it will use one. Restore does,
            ;; to close this undo group. The declaring call is absent on older
            ;; releases, so it is wrapped rather than tested for.
            (vl-catch-all-apply '(lambda ( ) (*push-error-using-command*)) '())
            (command "_.UNDO" "_Begin")
            (setq count 0)
            (foreach pair pairs
                (if (vl-position (car pair) chosen)
                    (progn
                        (vla-put-color (cdr pair) *TagTint:Colour*)
                        (setq count (1+ count))
                    )
                )
            )
            (princ (strcat "\n" (itoa count)
                           " attribute" (if (= 1 count) "" "s")
                           " recoloured."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (TagTint:Restore)
    (princ)
)

(princ)