modify lisp, add incremental numbering to area text

June 24, 2018

i am using lee-mac lisp "Areas2FieldV1-3" i managed to add prefix and suffix but i dont know how to add Increment numbering to the prefix.

for example: if i choose the first object it will show a1=xm2, and the next object will show a2=xm2.

http://www.lee-mac.com/lisp/Areas2FieldV1-3.lsp

June 25, 2018

Areas2FieldV1 sounds and looks like function (s) that calculates the area of things, then writes that number in an Mtext entity.

(Edit: it also live updates this number if you stretch the polylines ...)

Do you need the area of things, or just the "writing a number in an Mtext" part of the script?

If the latter is true you don't need 95% of that script, so let's just start from scratch.

Or maybe you need two separate scripts. Areas2FieldV1 works fine, Now you want a script that numbers things incrementally.

Please elaborate on that. What kind of increment system do you need? a1=xm2 What's the 1, what's the 2? What about the rest? ...

(EDIT: Ah, okay, I get it. that m2 is square meter, the x is the value, ...)

Edited June 25, 2018 by Emmanuel Delay

June 25, 2018

i need the area.

i only need the increment number next to the "a".

this what i got

;;------------------------=={ Areas to Field }==------------------------;;
;;                                                                      ;;
;;  This program allows a user to create an MText object containing a   ;;
;;  Field Expression referencing the area, or sum of areas, of one or   ;;
;;  more selected objects.                                              ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'A2F' at the AutoCAD command-line,  ;;
;;  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  ;;
;;  MText Field.                                                        ;;
;;                                                                      ;;
;;  Following object selection, the user is prompted to pick a point    ;;
;;  at which to create the MText Field. If the specified point resides  ;;
;;  within an AutoCAD table cell, the program will populate the table   ;;
;;  cell with the appropriate 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 - this formatting code may be altered to     ;;
;;  suit the user's requirements.                                       ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2014  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.3    -    2014-07-17                                      ;;
;;----------------------------------------------------------------------;;

(defun c:a2f ( / *error* fmt inc ins lst sel str )

   (setq fmt "A=%lu6%pr1 m²") ;; Field Formatting

   (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"))))
            (setq ins (getpoint "\nPick point or cell for field: "))
       )
       (progn
           (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))
               )
           )
           (if (= 1 (sslength sel))
               (setq str
                   (strcat
                       "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:ObjectID (vlax-ename->vla-object (ssname sel 0)))
                       ">%).Area \\f \"" fmt "\">%"
                   )
               )
               (progn
                   (repeat (setq idx (sslength sel))
                       (setq lst
                           (vl-list*
                               "%<\\AcObjProp Object(%<\\_ObjId "
                               (LM:ObjectID (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                               ">%).Area>%" " + "
                               lst
                           )
                       )
                   )
                   (setq str
                       (strcat
                           "%<\\AcExpr "
                           (apply 'strcat (reverse (cdr (reverse lst))))
                           " \\f \"" fmt "\">%"
                       )
                   )
               )
           )
           (LM:startundo (LM:acdoc))
           (if (setq tmp (LM:getcell tab (trans ins 1 0)))
               (apply 'vla-settext (append tmp (list str)))
               (vla-addmtext
                   (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                   (vlax-3D-point (trans ins 1 0))
                   0.0
                   str
               )
           )
           (LM:endundo (LM:acdoc))
       )
   )
   (princ)
)

;; 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
               (and
                   (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                   (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
               )
               (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
              '(itoa (vla-get-objectid obj))
           )
       )
   )
   (LM:ObjectID obj)
)

;; 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
   )
)

;; 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)

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

June 25, 2018

I added some code on top.

A global variable keeps the number

Then a string-replace function takes

(setq fmt "A*=%lu6%pr3 m²")

and turns the * into that number. So the number is incremented and assigned when you trigger the command a2f.

The rest should still work.

Do you need something extra to start numbering from something else than 1, 2, 3, ... ?

(EDIT: oh yes, I changed %lu6%pr1 to %lu6%pr3, which means 3 digits right of the point/comma . Feel free to put it back to 1)

(setq mynumber 0)
(defun increment (str / )
 (setq mynumber (+ mynumber 1))
 (vl-string-subst (itoa mynumber) "*" str)
)

;;------------------------=={ Areas to Field }==------------------------;;
;;                                                                      ;;
;;  This program allows a user to create an MText object containing a   ;;
;;  Field Expression referencing the area, or sum of areas, of one or   ;;
;;  more selected objects.                                              ;;
;;                                                                      ;;
;;  Upon issuing the command syntax 'A2F' at the AutoCAD command-line,  ;;
;;  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  ;;
;;  MText Field.                                                        ;;
;;                                                                      ;;
;;  Following object selection, the user is prompted to pick a point    ;;
;;  at which to create the MText Field. If the specified point resides  ;;
;;  within an AutoCAD table cell, the program will populate the table   ;;
;;  cell with the appropriate 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 - this formatting code may be altered to     ;;
;;  suit the user's requirements.                                       ;;
;;                                                                      ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2014  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.3    -    2014-07-17                                      ;;
;;----------------------------------------------------------------------;;

(defun c:a2f ( / *error* fmt inc ins lst sel str )

   (setq fmt "A*=%lu6%pr3 m²") ;; Field Formatting
   (setq fmt (increment fmt))
   (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"))))
            (setq ins (getpoint "\nPick point or cell for field: "))
       )
       (progn
           (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))
               )
           )
           (if (= 1 (sslength sel))
               (setq str
                   (strcat
                       "%<\\AcObjProp Object(%<\\_ObjId "
                       (LM:ObjectID (vlax-ename->vla-object (ssname sel 0)))
                       ">%).Area \\f \"" fmt "\">%"
                   )
               )
               (progn
                   (repeat (setq idx (sslength sel))
                       (setq lst
                           (vl-list*
                               "%<\\AcObjProp Object(%<\\_ObjId "
                               (LM:ObjectID (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
                               ">%).Area>%" " + "
                               lst
                           )
                       )
                   )
                   (setq str
                       (strcat
                           "%<\\AcExpr "
                           (apply 'strcat (reverse (cdr (reverse lst))))
                           " \\f \"" fmt "\">%"
                       )
                   )
               )
           )
           (LM:startundo (LM:acdoc))
           (if (setq tmp (LM:getcell tab (trans ins 1 0)))
               (apply 'vla-settext (append tmp (list str)))
               (vla-addmtext
                   (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
                   (vlax-3D-point (trans ins 1 0))
                   0.0
                   str
               )
           )
           (LM:endundo (LM:acdoc))
       )
   )
   (princ)
)

;; 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
               (and
                   (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
                   (vlax-method-applicable-p (vla-get-utility (LM:acdoc)) 'getobjectidstring)
               )
               (list 'vla-getobjectidstring (vla-get-utility (LM:acdoc)) 'obj ':vlax-false)
              '(itoa (vla-get-objectid obj))
           )
       )
   )
   (LM:ObjectID obj)
)

;; 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
   )
)

;; 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)

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

Edited June 25, 2018 by Emmanuel Delay

June 25, 2018

wow!! you are awsome!

thank you very much.

now i need to check what did you changed, maybe i will learn something haha:D

June 25, 2018

Yeah, I wanted to add a remark ...

   (setq fmt (increment fmt))
   ;; NO CODE WAS HARMED BELOW THIS POINT
   (defun *error* ( msg )

June 25, 2018

what this lines do?

June 25, 2018

oh, now i get it.

June 27, 2018

can i control on the increment number, reset it to 0 or another number to start from without changing the lisp each time.

maybe by using setting for the lisp or something like that?

June 27, 2018

The clue is the 1st line make it a "getreal" and then you can set start number.

(defun increment (str / )
(if (= mynumber nil) (setq mynumber 0))
(setq mynumber (+ mynumber 1))
(princ "\Current Number :<")(princ mynumber)
(setq askw (getint "> : "))
(if (/= askw nil)(setq mynumber askw))
       (vl-string-subst (itoa mynumber) "*" str)
)

June 28, 2018

Great feature added! Maybe Lee Mac picks it up.

July 4, 2018

i was trying to do the same thing to another lisp of his, but with no success

this lisp check the length and make it as text.

how to add the increment number near the "L"


;;-------------------------=={ 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
         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                              ;;
;;----------------------------------------------------------------------;;

Sign In

modify lisp, add incremental numbering to area text

Recommended Posts

alat

Emmanuel Delay

alat

Emmanuel Delay

alat

Emmanuel Delay

alat

alat

alat

BIGAL

halam

alat

Join the conversation

Tutorials

Forums

Activity