;;; ---------------------------------------------------------------------------
;;; LengthToTag.lsp
;;; code compiled by YZ August 2026
;;; ---------------------------------------------------------------------------
;;; Pushes a length - or the sum of several lengths - into a block ATTRIBUTE as
;;; a live field.
;;;
;;; Select the objects to measure, pick the attribute, and it is populated with
;;; a field showing the total. Because it is a field, editing the geometry
;;; updates the attribute automatically.
;;;
;;; The companion to AREATOTAG, for anything measured by run rather than by
;;; area - pipe lengths, kerb runs, cable routes, fence lines.
;;;
;;; THE RIGHT PROPERTY PER OBJECT TYPE
;;; A field must name the property it reads, and that name differs by type:
;;;
;;;     Arc        ArcLength
;;;     Circle     Circumference
;;;     Line       Length
;;;     Polyline   Length
;;;
;;; Asking a circle for its "Length" returns nothing, so the property is looked
;;; up from the object's class name rather than assumed.
;;;
;;; CHOOSING THE TARGET
;;; Pick either the attribute itself or anywhere on its block. A block with one
;;; attribute uses it without asking; one with several offers a list.
;;;
;;; Set LengthToTag:Tag below to a tag name - say "LENGTH" - and that attribute
;;; is used automatically whenever the picked block has one.
;;;
;;;   LENGTHTOTAG  - write a length field into an attribute
;;; ---------------------------------------------------------------------------

(vl-load-com)

;; Field formatting code. "%lu6" is decimal linear units; run FIELDSNOOP on a
;; field you like to discover other codes.
(setq LengthToTag:Format "%lu6")

;; Optional preset attribute tag; nil means always ask.
(setq LengthToTag:Tag nil)

;; ---------------------------------------------------------------------------
;; Class name to length property. Both 2D and 3D polylines report "Length".
;; ---------------------------------------------------------------------------
(setq LengthToTag:Properties
   '(
        ("AcDbArc"        . "ArcLength")
        ("AcDbCircle"     . "Circumference")
        ("AcDbLine"       . "Length")
        ("AcDbPolyline"   . "Length")
        ("AcDb2dPolyline" . "Length")
        ("AcDb3dPolyline" . "Length")
    )
)

;; ---------------------------------------------------------------------------
;; LengthToTag:Doc  -  cached active document
;; ---------------------------------------------------------------------------
(defun LengthToTag:Doc nil
    (eval (list 'defun 'LengthToTag:Doc 'nil
                (vla-get-activedocument (vlax-get-acad-object))
          )
    )
    (LengthToTag:Doc)
)

;; ---------------------------------------------------------------------------
;; LengthToTag:HexToDecimal
;; ---------------------------------------------------------------------------
;; Converts a hexadecimal string to decimal, as a string - needed because a
;; 64-bit object ID exceeds what an AutoLISP integer can hold, so the
;; conversion must be done on the text. The helpers perform long multiplication
;; by 16 through a digit list held least-significant first.
;; ---------------------------------------------------------------------------
(defun LengthToTag:HexToDecimal ( hex / LengthToTag:Accumulate LengthToTag:Carry )

    (defun LengthToTag:Accumulate ( lst rtn )
        (if lst
            (LengthToTag:Accumulate (cdr lst) (LengthToTag:Carry (- (car lst) (if (< 57 (car lst)) 55 48)) rtn))
            (apply 'strcat (mapcar 'itoa (reverse rtn)))
        )
    )

    (defun LengthToTag:Carry ( int lst )
        (if lst
            (if (or (< 0 (setq int (+ (* 16 (car lst)) int))) (cdr lst))
                (cons (rem int 10) (LengthToTag:Carry (/ int 10) (cdr lst)))
            )
            (LengthToTag:Carry int '(0))
        )
    )

    (LengthToTag:Accumulate (vl-string->list (strcase hex)) nil)
)

;; ---------------------------------------------------------------------------
;; LengthToTag:EnameToID
;; ---------------------------------------------------------------------------
;; Derives an object ID from an entity name's printed form - the fallback for
;; 64-bit AutoCAD versions predating GetObjectIdString.
;; ---------------------------------------------------------------------------
(defun LengthToTag:EnameToID ( ent )
    (LengthToTag:HexToDecimal
        (setq ent (vl-string-right-trim ">" (vl-prin1-to-string ent))
              ent (substr ent (+ (vl-string-position 58 ent) 3))
        )
    )
)

;; ---------------------------------------------------------------------------
;; LengthToTag:ObjectID
;; ---------------------------------------------------------------------------
;; Returns an object's ID as a string, by whichever method this AutoCAD
;; supports. The test runs once, then this function replaces itself.
;; ---------------------------------------------------------------------------
(defun LengthToTag:ObjectID ( obj )
    (eval
        (list 'defun 'LengthToTag:ObjectID '( obj )
            (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64*")
                (if (vlax-method-applicable-p (vla-get-utility (LengthToTag:Doc)) 'getobjectidstring)
                    (list 'vla-getobjectidstring
                          (vla-get-utility (LengthToTag:Doc)) 'obj ':vlax-false
                    )
                   '(LengthToTag:EnameToID (vlax-vla-object->ename obj))
                )
               '(itoa (vla-get-objectid obj))
            )
        )
    )
    (LengthToTag:ObjectID obj)
)

;; ---------------------------------------------------------------------------
;; LengthToTag:ListBox
;; ---------------------------------------------------------------------------
;; Single-select list returning the chosen index as a one-element list, or nil.
;; The dialog name "lengthtotag" must match between the DCL and new_dialog.
;; ---------------------------------------------------------------------------
(defun LengthToTag:ListBox ( msg lst / dch des tmp rtn )
    (cond
        (   (not
                (and
                    (setq tmp (vl-filename-mktemp nil nil ".dcl"))
                    (setq des (open tmp "w"))
                    (write-line
                        (strcat "lengthtotag:dialog{label=\"" msg "\";spacer;"
                                ":list_box{key=\"list\";multiple_select=false;width=50;height=15;}"
                                "spacer;ok_cancel;}"
                        )
                        des
                    )
                    (not (close des))
                    (< 0 (setq dch (load_dialog tmp)))
                    (new_dialog "lengthtotag" dch)
                )
            )
            (princ "\nThe attribute selection dialog could not be created.")
        )
        (   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)) (read (strcat "(" rtn ")"))))
        )
    )
    (if (and dch (< 0 dch)) (unload_dialog dch))
    (if (and tmp (setq tmp (findfile tmp))) (vl-file-delete tmp))
    rtn
)

;; ---------------------------------------------------------------------------
;; LengthToTag:Build
;; ---------------------------------------------------------------------------
;; Returns the field expression for the selected objects.
;;
;; One object gets a direct property reference; several get an AcExpr
;; arithmetic field summing them. Each object contributes the property name
;; appropriate to ITS own type, so a selection mixing arcs, circles and lines
;; still totals correctly.
;; ---------------------------------------------------------------------------
(defun LengthToTag:Build ( sel / idx obj parts )
    (if (= 1 (sslength sel))
        (progn
            (setq obj (vlax-ename->vla-object (ssname sel 0)))
            (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                    (LengthToTag:ObjectID obj)
                    ">%)."
                    (cdr (assoc (vla-get-objectname obj) LengthToTag:Properties))
                    " \\f \"" LengthToTag:Format "\">%"
            )
        )
        (progn
            (repeat (setq idx (sslength sel))
                (setq obj   (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                      parts (vl-list*
                                "%<\\AcObjProp Object(%<\\_ObjId "
                                (LengthToTag:ObjectID obj)
                                ">%)."
                                (cdr (assoc (vla-get-objectname obj) LengthToTag:Properties))
                                ">%" " + "
                                parts
                            )
                )
            )
            ;; The reverse/cdr/reverse strips the trailing " + " separator.
            (strcat "%<\\AcExpr "
                    (apply 'strcat (reverse (cdr (reverse parts))))
                    " \\f \"" LengthToTag:Format "\">%"
            )
        )
    )
)

;; ---------------------------------------------------------------------------
;; c:LENGTHTOTAG  -  main routine
;; ---------------------------------------------------------------------------
(defun c:LENGTHTOTAG ( / *error* vars vals sel pick enx att owner atts idx )

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

    (defun LengthToTag: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 )
        (LengthToTag:Restore)
        (if (and msg (not (wcmatch (strcase msg t) "*break*,*cancel*,*exit*")))
            (princ (strcat "\n** LENGTHTOTAG error: " msg " **"))
        )
        (princ)
    )

    (setvar "CMDECHO" 0)

    (if (and
            ;; The exclusion removes 3D polylines and meshes, whose class names
            ;; are not in the property table above.
            (setq sel
                (ssget
                   '(   (000 . "ARC,CIRCLE,LINE,*POLYLINE")
                        (-04 . "<NOT")
                            (-04 . "<AND") (000 . "POLYLINE") (-04 . "&") (070 . 80) (-04 . "AND>")
                        (-04 . "NOT>")
                    )
                )
            )
            (progn
                (while
                    (progn
                        (setvar 'errno 0)
                        (setq pick (nentsel "\nSelect attribute or attributed block: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null pick) nil)

                            ;; An attribute picked directly, with no preset tag.
                            (   (and (= "ATTRIB" (cdr (assoc 0 (setq enx (entget (car pick))))))
                                     (/= 'str (type LengthToTag:Tag))
                                )
                                (setq att (vlax-ename->vla-object (car pick)))
                                nil
                            )

                            ;; Otherwise find the owning block and its attributes.
                            (   (and
                                    (or (and (= "ATTRIB" (cdr (assoc 0 enx)))
                                             (setq owner (cdr (assoc 330 enx)))
                                        )
                                        (and (setq owner (last (cadddr pick)))
                                             (= "INSERT" (cdr (assoc 0 (entget owner))))
                                        )
                                    )
                                    (setq atts (vlax-invoke (vlax-ename->vla-object owner) 'getattributes))
                                )
                                (not
                                    (or
                                        (and (= 'str (type LengthToTag:Tag))
                                             (setq idx (vl-position (strcase LengthToTag:Tag)
                                                                    (mapcar 'vla-get-tagstring atts)))
                                             (setq att (nth idx atts))
                                        )
                                        (and (not (cdr atts)) (setq att (car atts)))
                                        (and (setq idx (LengthToTag:ListBox "Choose Attribute"
                                                           (mapcar 'vla-get-tagstring atts)))
                                             (setq att (nth (car idx) atts))
                                        )
                                    )
                                )
                            )

                            (   (princ "\nThat is not an attribute or an attributed block."))
                        )
                    )
                )
                (= 'vla-object (type att))
            )
        )
        (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")
            (vla-put-textstring att (LengthToTag:Build sel))

            ;; The field must be told to evaluate, or the attribute shows the
            ;; raw expression until the next regen.
            (vl-cmdf "_.updatefield" (vlax-vla-object->ename att) "")

            (princ (strcat "\nLength field written into attribute \""
                           (vla-get-tagstring att) "\" from "
                           (itoa (sslength sel)) " object"
                           (if (= 1 (sslength sel)) "" "s") "."
                   )
            )
        )
        (princ "\n*Cancelled*")
    )

    (LengthToTag:Restore)
    (princ)
)

(princ)