;;--------------------=={ Area Field to Attribute }==-------------------;;
;;                                                                      ;;
;;  This program allows a user to populate a selected attribute with    ;;
;;  a Field Expression referencing the area, or sum of areas, of one    ;;
;;  or more objects.                                                    ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'A2A' the user is prompted to       ;;
;;  make a selection of objects for which to retrieve the area; if      ;;
;;  more than one object is selected, the cumulative area for all       ;;
;;  objects will be displayed by the resultant Field Expression.        ;;
;;                                                                      ;;
;;  Following object selection, the user is then prompted to select     ;;
;;  either an attributed block or an attribute in which to house the    ;;
;;  Field Expression. The Field will display the sum of the areas of    ;;
;;  the selected objects, formatted using the Field formatting code     ;;
;;  specified at the top of the program.                                ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2013  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2016-01-16                                      ;;
;;----------------------------------------------------------------------;;

(defun c:a2a ( / *error* ats att enx fmt idx inc lst sel tag tmp )

    (setq fmt "%lu6%qf1" ;; Field Formatting
          tag nil        ;; Optional predefined attribute tag
    )
    
    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (if
        (and (setq sel (ssget '((0 . "ARC,CIRCLE,ELLIPSE,HATCH,*POLYLINE,REGION,SPLINE"))))
            (progn
                (while
                    (progn (setvar 'errno 0) (setq ats (nentsel "\nSelect attribute or attributed block: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null ats)
                                nil
                            )
                            (   (and (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (car ats))))))
                                     (/= 'str (type tag))
                                )
                                (setq att (vlax-ename->vla-object (car ats)))
                                nil
                            )
                            (   (and
                                    (or
                                        (and (= "ATTRIB" (cdr (assoc 0 enx)))
                                             (setq tmp (cdr (assoc 330 enx)))
                                        )
                                        (and (setq tmp  (last (cadddr ats)))
                                             (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                        )
                                    )
                                    (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                )
                                (not
                                    (or
                                        (and (= 'str (type tag))
                                             (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                             (setq att (nth idx tmp))
                                        )
                                        (and (not (cdr tmp))
                                             (setq att (car tmp))
                                        )
                                        (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
                                             (setq att (nth (car idx) tmp))
                                        )
                                    )
                                )
                            )
                            (   (princ "\nThe selected object is not an attribute or attributed block."))
                        )
                    )
                )
                (= 'vla-object (type att))
            )
        )
        (progn
            (LM:startundo (LM:acdoc))
            (if (= 1 (sslength sel))
                (vla-put-textstring att
                    (strcat
                        "%<\\AcObjProp Object(%<\\_ObjId "
                        (LM:objectid (vlax-ename->vla-object (ssname sel 0)))
                        ">%).Area \\f \"" fmt "\">%"
                    )
                )
                (progn
                    (repeat (setq inc (sslength sel))
                        (setq lst
                            (vl-list*
                                "%<\\AcObjProp Object(%<\\_ObjId "
                                (LM:objectid (vlax-ename->vla-object (ssname sel (setq inc (1- inc)))))
                                ">%).Area>%" " + "
                                lst
                            )
                        )
                    )
                    (vla-put-textstring att
                        (strcat
                            "%<\\AcExpr "
                            (apply 'strcat (reverse (cdr (reverse lst))))
                            " \\f \"" fmt "\">%"
                        )
                    )
                )
            )
            (vl-cmdf "_.updatefield" (vlax-vla-object->ename att) "")
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - [str] Dialog label
;; lst - [lst] List of strings to display
;; bit - [int] 1=allow multiple; 2=return indexes
;; Returns: [lst] List of selected items/indexes, else nil
 
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "listbox:dialog{label=\"" msg "\";spacer;:list_box{key=\"list\";multiple_select="
                            (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "listbox" dch)
                )
            )
            (prompt "\nError Loading List Box Dialog.")
        )
        (   t     
            (start_list "list")
            (foreach itm lst (add_list itm))
            (end_list)
            (setq rtn (set_tile "list" "0"))
            (action_tile "list" "(setq rtn $value)")
            (setq rtn
                (if (= 1 (start_dialog))
                    (if (= 2 (logand 2 bit))
                        (read (strcat "(" rtn ")"))
                        (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
                    )
                )
            )
        )
    )
    (if (< 0 dch)
        (unload_dialog dch)
    )
    (if (and tmp (setq tmp (findfile tmp)))
        (vl-file-delete tmp)
    )
    rtn
)

;; ObjectID  -  Lee Mac
;; Returns a string containing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems

(defun LM:objectid ( obj )
    (eval
        (list 'defun 'LM:objectid '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
                   '(LM:ename->objectid (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LM:objectid obj)
)

;; Entity Name to ObjectID  -  Lee Mac
;; Returns the 32-bit or 64-bit ObjectID for a supplied entity name

(defun LM:ename->objectid ( ent )
    (LM:hex->decstr
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; Hex to Decimal String  -  Lee Mac
;; Returns the decimal representation of a supplied hexadecimal string

(defun LM:hex->decstr ( hex / foo bar )
    (defun foo ( lst rtn )
        (if lst
            (foo (cdr lst) (bar (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )
    (defun bar ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (bar (/ int 10) (cdr lst)))
            )
            (bar int '(0))
        )
    )
    (foo (vl-string->list (strcase hex)) nil)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)

;;----------------------------------------------------------------------;;

(vl-load-com)
(princ
    (strcat
        "\n:: Areas2Attribute.lsp | Version 1.2 | \\U+00A9 Lee Mac "
        (menucmd "m=$(edtime,0,yyyy)")
        " www.lee-mac.com ::"
        "\n:: Type \"A2A\" to Invoke ::"
    )
)
(princ)

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