[LISP-LEEMAC] 속성객체 색상설정 (포스트아이디 : 8060868850830702893)

;; 출 처 : http://www.lee-mac.com/attributecolour.html
;; 제 목 : Attribute Colour
;; 버 전 : V1.0
;; 명령어 : AttCol
 ;;


;;-------------------=={ Attribute Colour }==-----------------;;
;;                                                            ;;
;;  Prompts for a selection of attributed blocks and displays ;;
;;  a dialog interface enabling the user to change the colour ;;
;;  of specific attribute tags.                               ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Version 1.0    -    24-02-2011                            ;;
;;                                                            ;;
;;  First Release.                                            ;;
;;------------------------------------------------------------;;

(defun c:AttCol ( / *error* _StartUndo _EndUndo _unique _dclsel _dclimg doc l s ss ) (vl-load-com)
  ;; ?Lee Mac 2011

  (or *attcolour* (setq *attcolour* 1)) ;; First time default colour

  (defun *error* ( msg )
    (if doc (_EndUndo doc))
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **")))
    (princ)
  )

  (defun _StartUndo ( doc ) (_EndUndo doc)
    (vla-StartUndoMark doc)
  )

  (defun _EndUndo ( doc )
    (if (= 8 (logand 8 (getvar 'UNDOCTL)))
      (vla-EndUndoMark doc)
    )
  )

  (defun _unique ( l ) (if l (cons (car l) (_unique (vl-remove (car l) (cdr l))))))

  (defun _dclsel ( l / file tmp dch return )
    (cond
      (
        (not
          (and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
            (write-line
              (strcat
                "attcol : dialog { label = \"Attribute 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 "attcol" dch)
          )
        )
      )
      (t
        (start_list "tags") (mapcar 'add_list l) (end_list)

        (setq return (set_tile "tags" "0"))
        (_dclimg "img" *attcolour*)

        (action_tile "img"  "(_dclimg \"img\" (setq *attcolour* (cond ( (acad_colordlg *attcolour*) ) ( *attcolour* ))))")
        (action_tile "but"  "(_dclimg \"img\" (setq *attcolour* (cond ( (acad_colordlg *attcolour*) ) ( *attcolour* ))))")
        (action_tile "tags" "(setq return $value)")

        (setq return
          (if (= 1 (start_dialog))
            (mapcar '(lambda ( x ) (nth x l)) (read (strcat "(" return ")")))
          )
        )
      )
    )

    (if (< 0 dch) (unload_dialog dch))
    (if (setq tmp (findfile tmp)) (vl-file-delete tmp))

    return
  )

  (defun _dclimg ( k c )
    (start_image k) (fill_image 0 0 (dimx_tile k) (dimy_tile k) c) (end_image)
  )

  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))

  (if
    (and (ssget "_:L" '((0 . "INSERT") (66 . 1)))
      (progn
        (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))        
          (foreach att
            (append (vlax-invoke obj 'GetAttributes) (vlax-invoke obj 'GetConstantAttributes))
            (setq l (cons (cons (vla-get-TagString att) att) l))
          )
        )
        (vla-delete ss)
        (setq s (_dclsel (acad_strlsort (_unique (mapcar 'car l)))))
      )
    )
    (progn
      (_StartUndo doc)
      (foreach pair l (if (vl-position (car pair) s) (vla-put-color (cdr pair) *attcolour*)))
      (_EndUndo doc)
    )
    (princ "\n*Cancel*")
  )

  (princ)
)

(princ)
(princ "\n:: AttributeColour.lsp | Version 1.0 | ?Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type \"AttCol\" to Invoke ::")
(princ)

;;------------------------------------------------------------;;
;;                         End of File                        ;;
;;------------------------------------------------------------;;