[编程交流] 向lis添加增量编号

;;-------------------------=={ Length Field }==-------------------------;;
;;                                                                      ;;
;;  This program allows a user to generate a field expression           ;;
;;  referencing the length/perimeter/circumference of one or more       ;;
;;  selected objects. In the case of selecting multiple objects, the    ;;
;;  field expression will reference the sum of the lengths of all       ;;
;;  objects in the selection.                                           ;;
;;                                                                      ;;
;;  The user may opt to specify a point at which to create a new        ;;
;;  multiline text object housing the field expression, pick a table    ;;
;;  cell in which the field should be inserted, or select an existing   ;;
;;  single-line text, multiline text, multileader, or attribute to      ;;
;;  be populated with the field expression.                             ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'LF' (Length Field) at the AutoCAD  ;;
;;  command-line, the program first prompts the user to make a          ;;
;;  selection of objects for which to return the length summation.      ;;
;;                                                                      ;;
;;  At this prompt, the user may select any number of Arcs, Circles,    ;;
;;  Lines, 2D Polylines (light or heavy), or 3D Polylines.              ;;
;;                                                                      ;;
;;  The user is then prompted to specify a point or table cell to       ;;
;;  insert a field expression referencing the summation of the lengths  ;;
;;  of the selected objects.                                            ;;
;;                                                                      ;;
;;  At this prompt, the user may also choose the 'Object' option in     ;;
;;  order to populate the content of an existing annotation object      ;;
;;  with the field expression.                                          ;;
;;                                                                      ;;
;;  Upon choosing this option, the user may select any single-line      ;;
;;  text (DText), multiline text (MText), single-line or multiline      ;;
;;  attribute, attributed block, or multileader (MLeader) with either   ;;
;;  multiline text or attributed block content.                         ;;
;;                                                                      ;;
;;  If the user selects an attributed block or attributed multileader   ;;
;;  with more than one attribute, the user is presented with a dialog   ;;
;;  interface listing the available attributes, and is prompted to      ;;
;;  select a destination for the field expression.                      ;;
;;                                                                      ;;
;;  The user may optionally predefine the target block/multileader      ;;
;;  attribute by specifying the attribute tag where noted at the top    ;;
;;  of the program source code.                                         ;;
;;                                                                      ;;
;;  The resulting field expression will display the sum of the lengths  ;;
;;  of the selected objects, formatted using the field formatting code  ;;
;;  specified at the top of the program.                                ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2017  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2017-08-06                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2017-08-06                                      ;;
;;                                                                      ;;
;;  - Program modified to account for selection of existing annotation  ;;
;;    objects which already contain a field expression.                 ;;
;;----------------------------------------------------------------------;;
(defun c:lf ( / *error* ent enx flg fmt idx lst obj oid prp sel str tab tag tmp typ )
   (setq fmt "L=%lu6%pr2 cm" ;; Field Formatting ;; L1, L2, L3, L...
         tag nil    ;; Optional predefined attribute tag
   )
   
   (defun *error* ( msg )
       (LM:endundo (LM:acdoc))
       (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
           (princ (strcat "\nError: " msg))
       )
       (princ)
   )
   (LM:startundo (LM:acdoc))
   (setq prp
      '(
           ("AcDbArc"        . "ArcLength")
           ("AcDbCircle"     . "Circumference")
           ("AcDbLine"       . "Length")
           ("AcDbPolyline"   . "Length")
           ("AcDb2dPolyline" . "Length")
           ("AcDb3dPolyline" . "Length")
       )
   )
   (if
       (setq sel
           (LM:ssget "\nSelect objects to obtain total length <exit>: "
               (list
                   (list
                      '(000 . "ARC,CIRCLE,LINE,*POLYLINE")
                      '(-04 . "<NOT")
                          '(-04 . "<AND")
                              '(000 . "POLYLINE") '(-04 . "&") '(070 . 80)
                          '(-04 . "AND>")
                      '(-04 . "NOT>")
                       (if (= 1 (getvar 'cvport))
                           (cons 410 (getvar 'ctab))
                          '(410 . "Model")
                       )
                   )
               )
           )
       )
       (progn
           (if (= 1 (sslength sel))
               (setq obj (vlax-ename->vla-object (ssname sel 0))
                     str 
                   (strcat
                       "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:objectid obj)
                       ">%)." (cdr (assoc (vla-get-objectname obj) prp)) " \\f "" fmt "">%"
                   )
               )
               (progn
                   (repeat (setq idx (sslength sel))
                       (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                             lst
                           (vl-list*
                               "%<\\AcObjProp Object(%<\\_ObjId "
                               (LM:objectid obj)
                               ">%)." (cdr (assoc (vla-get-objectname obj) prp)) ">%" " + "
                               lst
                           )
                       )
                   )
                   (setq str
                       (strcat
                           "%<\\AcExpr "
                           (apply 'strcat (reverse (cdr (reverse lst))))
                           " \\f "" fmt "">%"
                       )
                   )
               )
           )
           (if
               (setq tmp
                   (ssget "_X"
                       (list '(0 . "ACAD_TABLE")
                           (if (= 1 (getvar 'cvport))
                               (cons 410 (getvar 'ctab))
                              '(410 . "Model")
                           )
                       )
                   )
               )
               (repeat (setq idx (sslength tmp))
                   (setq tab (cons (vlax-ename->vla-object (ssname tmp (setq idx (1- idx)))) tab))
               )
           )
           (while
               (not
                   (progn
                       (if flg
                           (progn
                               (setvar 'errno 0)
                               (initget "Point eXit")
                               (setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block [Point/eXit] <eXit>: "))
                           )
                           (progn
                               (initget "Object eXit")
                               (setq sel (getpoint "\nSpecify point or cell for field [Object/eXit] <eXit>: "))
                           )
                       )
                       (cond
                           (   (= 7 (getvar 'errno))
                               (prompt "\nMissed, try again.")
                           )
                           (   (or (null sel) (= "eXit" sel)))
                           (   (= "Point" sel)
                               (setq flg nil)
                           )
                           (   (= "Object" sel)
                               (not (setq flg t))
                           )
                           (   flg
                               (setq ent (car sel)
                                     enx (entget ent)
                                     typ (cdr (assoc 0 enx))
                                     obj (vlax-ename->vla-object ent)
                               )
                               (cond
                                   (   (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
                                       (if (vlax-write-enabled-p obj)
                                           (LF:puttextstring obj str)
                                           (prompt "\nThe selected text object is on a locked layer.")
                                       )
                                   )
                                   (   (and (= "ATTRIB" typ)
                                            (/= 'str (type tag))
                                       )
                                       (if (vlax-write-enabled-p obj)
                                           (progn
                                               (LF:puttextstring obj str)
                                               (LF:updatefield ent)
                                           )
                                           (prompt "\nThe selected attribute is on a locked layer.")
                                       )
                                   )
                                   (   (and
                                           (or
                                               (and (= "ATTRIB" typ)
                                                    (setq tmp (cdr (assoc 330 enx)))
                                               )
                                               (and (setq tmp (last (cadddr sel)))
                                                    (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                               )
                                           )
                                           (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                           (or
                                               (and (= 'str (type tag))
                                                    (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                                    (setq obj (nth idx tmp))
                                               )
                                               (and (not (cdr tmp))
                                                    (setq obj (car tmp))
                                               )
                                               (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
                                                    (setq obj (nth (car idx) tmp))
                                               )
                                           )
                                       )
                                       (if (vlax-write-enabled-p obj)
                                           (progn
                                               (LF:puttextstring obj str)
                                               (LF:updatefield (vlax-vla-object->ename obj))
                                           )
                                           (prompt "\nThe selected attribute is on a locked layer.")
                                       )
                                   )
                                   (   (and (= 2 (length sel)) (= "MULTILEADER" typ))
                                       (setq typ (cdr (assoc 172 (reverse enx))))
                                       (cond
                                           (   (and (<= acblockcontent typ acmtextcontent) (not (vlax-write-enabled-p obj)))
                                               (prompt "\nThe selected multileader is on a locked layer.")
                                           )
                                           (   (= acmtextcontent typ)
                                               (LF:puttextstring obj str)
                                               (vla-regen (LM:acdoc) acactiveviewport)
                                               t
                                           )
                                           (   (and
                                                   (= acblockcontent typ)
                                                   (setq tmp (LM:getmleaderattributes obj))
                                                   (or
                                                       (and (= 'str (type tag))
                                                            (setq oid (cdr (assoc (strcase tag) tmp)))
                                                       )
                                                       (and (not (cdr tmp))
                                                            (setq oid (cdar tmp))
                                                       )
                                                       (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'car tmp) 2))
                                                            (setq oid (cdr (nth (car idx) tmp)))
                                                       )
                                                   )
                                               )
                                               (LM:setmleaderattributevalue obj oid str)
                                               (vla-regen (LM:acdoc) acactiveviewport)
                                               t
                                           )
                                           (   (prompt "\nThe select multileader has no editable content."))
                                       )
                                   )
                                   (   (prompt "\nThe selected object is not text, mtext, multileader, attribute or attributed block."))
                               )
                           )
                           (   (setq tmp (LM:getcell tab (trans sel 1 0)))
                               (if (vlax-write-enabled-p (car tmp))
                                   (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-settext (append tmp (list str)))))
                                   (prompt "\nThe selected table cell belongs to a table on a locked layer.")
                               )
                           )
                           (   (vla-addmtext
                                   (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                                   (vlax-3D-point (trans sel 1 0))
                                   0.0
                                   str
                               )
                           )
                       )
                   )
               )
           )
       )
   )
   (*error* nil) (princ)
)
(defun LF:puttextstring ( obj str )
   (vla-put-textstring obj "") ;; To clear any existing field
   (vla-put-textstring obj str)
   t
)
(defun LF:updatefield ( ent / cmd rtn )
   (setq cmd (getvar 'cmdecho))
   (setvar 'cmdecho 0)
   (setq rtn (vl-cmdf "_.updatefield" ent ""))
   (setvar 'cmdecho cmd)
   rtn
)
;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
   (princ msg)
   (setvar 'nomutt 1)
   (setq sel (vl-catch-all-apply 'ssget arg))
   (setvar 'nomutt 0)
   (if (not (vl-catch-all-error-p sel)) sel)
)
;; Get MLeader Attributes  -  Lee Mac
;; Returns an association list of attribute tags & object IDs for all attributes held by an mleader block
;; mld - [vla] MLeader vla-object
;; Returns: [lst] List of ((<Attribute Tag> . <Object ID>) ... )
(defun LM:getmleaderattributes ( mld / rtn )
   (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld))
       (if
           (and
               (= "AcDbAttributeDefinition" (vla-get-objectname obj))
               (= :vlax-false (vla-get-constant obj))
           )
           (setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (LM:intobjectid obj)) rtn))
       )
   )
   (reverse rtn)
)
;; Object ID (integer)  -  Lee Mac
;; Returns an integer representing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems
(defun LM:intobjectid ( obj )
   (if (vlax-property-available-p obj 'objectid32)
       (defun LM:intobjectid ( obj ) (vla-get-objectid32 obj))
       (defun LM:intobjectid ( obj ) (vla-get-objectid   obj))
   )
   (LM:intobjectid obj)
)
;; Set MLeader Attribute Value  -  Lee Mac
;; obj - [vla] MLeader vla-object
;; idx - [int] Attribute Definition Object ID
;; str - [str] Attribute value
(defun LM:setmleaderattributevalue ( obj idx str )
   (if (vlax-method-applicable-p obj 'setblockattributevalue32)
       (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
       (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue   obj idx str))
   )
   (LM:setmleaderattributevalue obj idx str)
)
;; 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
)
;; Get Cell  -  Lee Mac
;; If the supplied point lies within a cell boundary,
;; returns a list of: (<VLA Table Object> <Row> <Col>)
(defun LM:getcell ( lst pnt / dir )
   (setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
         pnt (vlax-3D-point pnt)
   )
   (vl-some
      '(lambda ( tab / row col )
           (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
               (list tab row col)
           )
       )
       lst
   )
)
;; 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:: LengthField.lsp | Version 1.0 | \\U+00A9 Lee Mac "
       (menucmd "m=$(edtime,0,yyyy)")
       " www.lee-mac.com ::"
       "\n:: Type "LF" to Invoke ::"
   )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;

(setq mynumber 0)
(defun increment (str / )
 (setq mynumber (+ mynumber 1))
 (vl-string-subst (itoa mynumber) "*" str)
)
;;-------------------------=={ Length Field }==-------------------------;;
;;                                                                      ;;
;;  This program allows a user to generate a field expression           ;;
;;  referencing the length/perimeter/circumference of one or more       ;;
;;  selected objects. In the case of selecting multiple objects, the    ;;
;;  field expression will reference the sum of the lengths of all       ;;
;;  objects in the selection.                                           ;;
;;                                                                      ;;
;;  The user may opt to specify a point at which to create a new        ;;
;;  multiline text object housing the field expression, pick a table    ;;
;;  cell in which the field should be inserted, or select an existing   ;;
;;  single-line text, multiline text, multileader, or attribute to      ;;
;;  be populated with the field expression.                             ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'LF' (Length Field) at the AutoCAD  ;;
;;  command-line, the program first prompts the user to make a          ;;
;;  selection of objects for which to return the length summation.      ;;
;;                                                                      ;;
;;  At this prompt, the user may select any number of Arcs, Circles,    ;;
;;  Lines, 2D Polylines (light or heavy), or 3D Polylines.              ;;
;;                                                                      ;;
;;  The user is then prompted to specify a point or table cell to       ;;
;;  insert a field expression referencing the summation of the lengths  ;;
;;  of the selected objects.                                            ;;
;;                                                                      ;;
;;  At this prompt, the user may also choose the 'Object' option in     ;;
;;  order to populate the content of an existing annotation object      ;;
;;  with the field expression.                                          ;;
;;                                                                      ;;
;;  Upon choosing this option, the user may select any single-line      ;;
;;  text (DText), multiline text (MText), single-line or multiline      ;;
;;  attribute, attributed block, or multileader (MLeader) with either   ;;
;;  multiline text or attributed block content.                         ;;
;;                                                                      ;;
;;  If the user selects an attributed block or attributed multileader   ;;
;;  with more than one attribute, the user is presented with a dialog   ;;
;;  interface listing the available attributes, and is prompted to      ;;
;;  select a destination for the field expression.                      ;;
;;                                                                      ;;
;;  The user may optionally predefine the target block/multileader      ;;
;;  attribute by specifying the attribute tag where noted at the top    ;;
;;  of the program source code.                                         ;;
;;                                                                      ;;
;;  The resulting field expression will display the sum of the lengths  ;;
;;  of the selected objects, formatted using the field formatting code  ;;
;;  specified at the top of the program.                                ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2017  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2017-08-06                                      ;;
;;                                                                      ;;
;;  - First release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2017-08-06                                      ;;
;;                                                                      ;;
;;  - Program modified to account for selection of existing annotation  ;;
;;    objects which already contain a field expression.                 ;;
;;----------------------------------------------------------------------;;
(defun c:lf ( / *error* ent enx flg fmt idx lst obj oid prp sel str tab tag tmp typ )
   (setq fmt "L=%lu6%pr2 cm" ;; Field Formatting
   (setq fmt (increment fmt))
         tag nil    ;; Optional predefined attribute tag
   )
   
   (defun *error* ( msg )
       (LM:endundo (LM:acdoc))
       (if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
           (princ (strcat "\nError: " msg))
       )
       (princ)
   )
   (LM:startundo (LM:acdoc))
   (setq prp
      '(
           ("AcDbArc"        . "ArcLength")
           ("AcDbCircle"     . "Circumference")
           ("AcDbLine"       . "Length")
           ("AcDbPolyline"   . "Length")
           ("AcDb2dPolyline" . "Length")
           ("AcDb3dPolyline" . "Length")
       )
   )
   (if
       (setq sel
           (LM:ssget "\nSelect objects to obtain total length <exit>: "
               (list
                   (list
                      '(000 . "ARC,CIRCLE,LINE,*POLYLINE")
                      '(-04 . "<NOT")
                          '(-04 . "<AND")
                              '(000 . "POLYLINE") '(-04 . "&") '(070 . 80)
                          '(-04 . "AND>")
                      '(-04 . "NOT>")
                       (if (= 1 (getvar 'cvport))
                           (cons 410 (getvar 'ctab))
                          '(410 . "Model")
                       )
                   )
               )
           )
       )
       (progn
           (if (= 1 (sslength sel))
               (setq obj (vlax-ename->vla-object (ssname sel 0))
                     str 
                   (strcat
                       "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:objectid obj)
                       ">%)." (cdr (assoc (vla-get-objectname obj) prp)) " \\f "" fmt "">%"
                   )
               )
               (progn
                   (repeat (setq idx (sslength sel))
                       (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                             lst
                           (vl-list*
                               "%<\\AcObjProp Object(%<\\_ObjId "
                               (LM:objectid obj)
                               ">%)." (cdr (assoc (vla-get-objectname obj) prp)) ">%" " + "
                               lst
                           )
                       )
                   )
                   (setq str
                       (strcat
                           "%<\\AcExpr "
                           (apply 'strcat (reverse (cdr (reverse lst))))
                           " \\f "" fmt "">%"
                       )
                   )
               )
           )
           (if
               (setq tmp
                   (ssget "_X"
                       (list '(0 . "ACAD_TABLE")
                           (if (= 1 (getvar 'cvport))
                               (cons 410 (getvar 'ctab))
                              '(410 . "Model")
                           )
                       )
                   )
               )
               (repeat (setq idx (sslength tmp))
                   (setq tab (cons (vlax-ename->vla-object (ssname tmp (setq idx (1- idx)))) tab))
               )
           )
           (while
               (not
                   (progn
                       (if flg
                           (progn
                               (setvar 'errno 0)
                               (initget "Point eXit")
                               (setq sel (nentsel "\nSelect text, mtext, mleader, attribute or attributed block [Point/eXit] <eXit>: "))
                           )
                           (progn
                               (initget "Object eXit")
                               (setq sel (getpoint "\nSpecify point or cell for field [Object/eXit] <eXit>: "))
                           )
                       )
                       (cond
                           (   (= 7 (getvar 'errno))
                               (prompt "\nMissed, try again.")
                           )
                           (   (or (null sel) (= "eXit" sel)))
                           (   (= "Point" sel)
                               (setq flg nil)
                           )
                           (   (= "Object" sel)
                               (not (setq flg t))
                           )
                           (   flg
                               (setq ent (car sel)
                                     enx (entget ent)
                                     typ (cdr (assoc 0 enx))
                                     obj (vlax-ename->vla-object ent)
                               )
                               (cond
                                   (   (and (= 2 (length sel)) (wcmatch typ "TEXT,MTEXT"))
                                       (if (vlax-write-enabled-p obj)
                                           (LF:puttextstring obj str)
                                           (prompt "\nThe selected text object is on a locked layer.")
                                       )
                                   )
                                   (   (and (= "ATTRIB" typ)
                                            (/= 'str (type tag))
                                       )
                                       (if (vlax-write-enabled-p obj)
                                           (progn
                                               (LF:puttextstring obj str)
                                               (LF:updatefield ent)
                                           )
                                           (prompt "\nThe selected attribute is on a locked layer.")
                                       )
                                   )
                                   (   (and
                                           (or
                                               (and (= "ATTRIB" typ)
                                                    (setq tmp (cdr (assoc 330 enx)))
                                               )
                                               (and (setq tmp (last (cadddr sel)))
                                                    (= "INSERT" (cdr (assoc 0 (entget tmp))))
                                               )
                                           )
                                           (setq tmp (vlax-invoke (vlax-ename->vla-object tmp) 'getattributes))
                                           (or
                                               (and (= 'str (type tag))
                                                    (setq idx (vl-position (strcase tag) (mapcar 'vla-get-tagstring tmp)))
                                                    (setq obj (nth idx tmp))
                                               )
                                               (and (not (cdr tmp))
                                                    (setq obj (car tmp))
                                               )
                                               (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'vla-get-tagstring tmp) 2))
                                                    (setq obj (nth (car idx) tmp))
                                               )
                                           )
                                       )
                                       (if (vlax-write-enabled-p obj)
                                           (progn
                                               (LF:puttextstring obj str)
                                               (LF:updatefield (vlax-vla-object->ename obj))
                                           )
                                           (prompt "\nThe selected attribute is on a locked layer.")
                                       )
                                   )
                                   (   (and (= 2 (length sel)) (= "MULTILEADER" typ))
                                       (setq typ (cdr (assoc 172 (reverse enx))))
                                       (cond
                                           (   (and (<= acblockcontent typ acmtextcontent) (not (vlax-write-enabled-p obj)))
                                               (prompt "\nThe selected multileader is on a locked layer.")
                                           )
                                           (   (= acmtextcontent typ)
                                               (LF:puttextstring obj str)
                                               (vla-regen (LM:acdoc) acactiveviewport)
                                               t
                                           )
                                           (   (and
                                                   (= acblockcontent typ)
                                                   (setq tmp (LM:getmleaderattributes obj))
                                                   (or
                                                       (and (= 'str (type tag))
                                                            (setq oid (cdr (assoc (strcase tag) tmp)))
                                                       )
                                                       (and (not (cdr tmp))
                                                            (setq oid (cdar tmp))
                                                       )
                                                       (and (setq idx (LM:listbox "Choose Attribute" (mapcar 'car tmp) 2))
                                                            (setq oid (cdr (nth (car idx) tmp)))
                                                       )
                                                   )
                                               )
                                               (LM:setmleaderattributevalue obj oid str)
                                               (vla-regen (LM:acdoc) acactiveviewport)
                                               t
                                           )
                                           (   (prompt "\nThe select multileader has no editable content."))
                                       )
                                   )
                                   (   (prompt "\nThe selected object is not text, mtext, multileader, attribute or attributed block."))
                               )
                           )
                           (   (setq tmp (LM:getcell tab (trans sel 1 0)))
                               (if (vlax-write-enabled-p (car tmp))
                                   (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-settext (append tmp (list str)))))
                                   (prompt "\nThe selected table cell belongs to a table on a locked layer.")
                               )
                           )
                           (   (vla-addmtext
                                   (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                                   (vlax-3D-point (trans sel 1 0))
                                   0.0
                                   str
                               )
                           )
                       )
                   )
               )
           )
       )
   )
   (*error* nil) (princ)
)
(defun LF:puttextstring ( obj str )
   (vla-put-textstring obj "") ;; To clear any existing field
   (vla-put-textstring obj str)
   t
)
(defun LF:updatefield ( ent / cmd rtn )
   (setq cmd (getvar 'cmdecho))
   (setvar 'cmdecho 0)
   (setq rtn (vl-cmdf "_.updatefield" ent ""))
   (setvar 'cmdecho cmd)
   rtn
)
;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments
(defun LM:ssget ( msg arg / sel )
   (princ msg)
   (setvar 'nomutt 1)
   (setq sel (vl-catch-all-apply 'ssget arg))
   (setvar 'nomutt 0)
   (if (not (vl-catch-all-error-p sel)) sel)
)
;; Get MLeader Attributes  -  Lee Mac
;; Returns an association list of attribute tags & object IDs for all attributes held by an mleader block
;; mld - [vla] MLeader vla-object
;; Returns: [lst] List of ((<Attribute Tag> . <Object ID>) ... )
(defun LM:getmleaderattributes ( mld / rtn )
   (vlax-for obj (vla-item (vla-get-blocks (vla-get-document mld)) (vla-get-contentblockname mld))
       (if
           (and
               (= "AcDbAttributeDefinition" (vla-get-objectname obj))
               (= :vlax-false (vla-get-constant obj))
           )
           (setq rtn (cons (cons (strcase (vla-get-tagstring obj)) (LM:intobjectid obj)) rtn))
       )
   )
   (reverse rtn)
)
;; Object ID (integer)  -  Lee Mac
;; Returns an integer representing the ObjectID of a supplied VLA-Object
;; Compatible with 32-bit & 64-bit systems
(defun LM:intobjectid ( obj )
   (if (vlax-property-available-p obj 'objectid32)
       (defun LM:intobjectid ( obj ) (vla-get-objectid32 obj))
       (defun LM:intobjectid ( obj ) (vla-get-objectid   obj))
   )
   (LM:intobjectid obj)
)
;; Set MLeader Attribute Value  -  Lee Mac
;; obj - [vla] MLeader vla-object
;; idx - [int] Attribute Definition Object ID
;; str - [str] Attribute value
(defun LM:setmleaderattributevalue ( obj idx str )
   (if (vlax-method-applicable-p obj 'setblockattributevalue32)
       (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue32 obj idx str))
       (defun LM:setmleaderattributevalue ( obj idx str ) (vla-setblockattributevalue   obj idx str))
   )
   (LM:setmleaderattributevalue obj idx str)
)
;; 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
)
;; Get Cell  -  Lee Mac
;; If the supplied point lies within a cell boundary,
;; returns a list of: (<VLA Table Object> <Row> <Col>)
(defun LM:getcell ( lst pnt / dir )
   (setq dir (vlax-3D-point (trans (getvar 'viewdir) 1 0))
         pnt (vlax-3D-point pnt)
   )
   (vl-some
      '(lambda ( tab / row col )
           (if (= :vlax-true (vla-hittest tab pnt dir 'row 'col))
               (list tab row col)
           )
       )
       lst
   )
)
;; 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:: LengthField.lsp | Version 1.0 | \\U+00A9 Lee Mac "
       (menucmd "m=$(edtime,0,yyyy)")
       " www.lee-mac.com ::"
       "\n:: Type "LF" to Invoke ::"
   )
)
(princ)
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;