Adding A Background Mask & Feet Squared To A LISP Routine

[wilsons3774183]

Hi,

This is my first post here and was hoping i could get some help or guidance to modify a lisp routine.
Based on Lee Macs great routine A2F (Area To Field) with some modifications done at a previous company, i am looking at adding a background mask for the text and if possible also adding feet squared to the lisp routine so that the calculation for the area will show as both meters squared and feet squared.
I am very limited to LISP coding and would really appreciate any help with this.

[Tom Beauford]

To add Background Mask change:

				(vla-addmtext
					(vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
					(vlax-3D-point (trans ins 1 0))
					0.0
					str
				)

to

                (progn
				  (vla-addmtext
					  (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
					  (vlax-3D-point (trans ins 1 0))
					  0.0
					  str
				  )
				  (setq obj (vlax-ename->vla-object (entlast)))
				  (vlax-put-property obj 'BackgroundFill :vlax-true)
                )

You're going to need to add two separate fields in that Mtext, one for m² and one for ft². Do you want them as two lines or one?
It would be easier if you attached a drawing with a closed polyline with an Mtext label displayed as you want it. The fields depend on unit settings in the drawing and would not display the same on my drawings set to feet.

[wilsons3774183]

Hi Tom,

Thanks for your help on this.

I have attached a drawing with an example of how i would like the text, but in saying that even if it is on 2 lines that is ok.

Really appreciate your help on this.

Scott

[Tom Beauford]

Try this version:

;;------------------------=={ 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                                      ;;
;;----------------------------------------------------------------------;;
;;  Modifications completed to suit specific requirements OCT 2016      ;;
;;  Further updates October 2019                                        ;;
;;----------------------------------------------------------------------;;
;
(defun c:a2fm ( / *error* fmt prop inc ins lst sel str )
 (setq oldtextstyle (getvar "textstyle")) ;added by MC
 (setvar "textstyle" "ARIAL")  ;added by SW
 (setq oldlay (getvar "clayer")) ;added by MC
 (setvar "clayer" "1_5_TEXT")     ;added by SW
 (command "color" "bylayer")     ;added by MC

    ;(setq fmt "%lu2%pr1%ps%ct8[1e-006]% m²%qf1") ;; Field Formatting
    (setq fmt "%lu2%pr1%ps%ct8[1e-006]%th44%qf1% m²")
    (setq ftfmt "%lu2%qf1%pr0% ft²%ct8[1.076391041670998E-005]%th44")

    (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 "\">%"
                        " "
                        "%<\\AcObjProp Object(%<\\_ObjId "
                        (LM:ObjectID (vlax-ename->vla-object (ssname sel 0)))
                        ">%).Area \\f \"" ftfmt "\">%"
                    )
                )
                (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 "\">%"
                            " "
                            "%<\\AcExpr "
                            (apply 'strcat (reverse (cdr (reverse lst))))
                            " \\f \"" ftfmt "\">%"
                        )
                    )
                )
            )
            (princ "\nstr = ")(princ str)
            (LM:startundo (LM:acdoc))
            (if (setq tmp (LM:getcell tab (trans ins 1 0)))
                (apply 'vla-settext (append tmp (list str)))
                (progn
				  (vla-addmtext
					  (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
					  (vlax-3D-point (trans ins 1 0))
					  0.0
					  str
				  )
				  (setq obj (vlax-ename->vla-object (entlast)))
				  (vlax-put-property obj 'BackgroundFill :vlax-true)
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
(setvar "textstyle" oldtextstyle)  ;reset by MC
(setvar "clayer" oldlay)
(setvar "cmdecho" 0)
(command "move" "L" "" "D" "@0,250") ;added by MC
(command "justifytext" "L" "" "BL")
(setvar "cmdecho" 1)
(princ)
)

;; ObjectID
;; 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
;; 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
;; Opens an Undo Group.

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

;; End Undo
;; Closes an Undo Group.

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

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

[wilsons3774183]

Thanks Tom,

But that didn't seem to work, i kept getting the following message:
Pick point or cell for field:
str = %<\AcObjProp Object(%<\_ObjId 1819856010144>%).Area \f "%lu2%pr1%ps%ct8[1e-006]%th44%qf1% m²">% %<\AcObjProp Object(%<\_ObjId 1819856010144>%).Area \f "%lu2%qf1%pr0% ft²%ct8[1.076391041670998E-005]%th44">%

then it just stops.

[wilsons3774183]

Hi Again Tom,

Please disregard, it working perfectly.
Really Appreciate your help on this.

Scott

[wilsons3774183]

I have another one that i have been trying to work out and im really not getting anywhere. The attached lisp lets you select closed polyline areas to add, then select another closed polyline to subtract. I also need to have a background mask around the text as well as add ft².

I have also attached an example drawing. So in the end i can select the big rectangle then subtract to small rectangle to give an area of the remaining space. This should read in both m² and ft² with a background mask as with the previous drawing.


Once again thanks for the help.

[Tom Beauford]

This should do what you want:

;;  ------------------------------------------------------------------  ;;
;;  NA (Net Area)                                                       ;;
;;  ------------------------------------------------------------------  ;;
;;  This Command will calculate an area while also subtracting any      ;;
;;  Area selected by user                                               ;;
;;  ------------------------------------------------------------------  ;;
;
(defun c:NA  (/ ss1 ss2 i mtvalue1 mtvalue2 varlst obj)
	(princ "\nNet area calculation")
	(setq oldlayer (getvar "clayer"))
	(setvar "clayer" "1_5_TEXT")
	(command "-color" "bylayer") ;;edit by MC
	(command "_-style" "FIXTURE PLAN AREA" "ARIAL" "250" "" "" "" "")
  (setq varlst (mapcar 'getvar (list 'cmdecho 'nomutt)))
 ; (mapcar 'setvar (list 'cmdecho 'nomutt) (list 0 1))
  (prompt "\nSelect Polylines to Add: ")
  (setq ss1 (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (70 . 1) (70 . 129) (-4 . "OR>"))))
  ;(mapcar 'setvar (list 'cmdecho 'nomutt) (list 1 0))
  (prompt "\nSelect Polylines to Subtract: ")
 ; (mapcar 'setvar (list 'cmdecho 'nomutt) (list 0 1))
  (setq ss2 (ssget '((0 . "LWPOLYLINE") (-4 . "<OR") (70 . 1) (70 . 129) (-4 . "OR>")))
        i   0)
  (repeat (sslength ss1)
    (setq mtvalue1 (strcat (if mtvalue1
                             mtvalue1
                             "")
                           (itoa (vla-get-objectID (vlax-ename->vla-object (ssname ss1 i))))
                           ">%).Area \\f \"%lu2%pr1%ps[, m²]%ct8[1e-006]\">%+%<\\AcObjProp Object(%<\\_ObjId ")
          i        (1+ i)))
  (setq i 0)
  (repeat (sslength ss2)
    (setq mtvalue2 (strcat (if mtvalue2
                             mtvalue2
                             "")
                           (itoa (vla-get-objectID (vlax-ename->vla-object (ssname ss2 i))))
                           ">%).Area \\f \"%lu2%pr1%ps[, m²]%ct8[1e-006]\">%-%<\\AcObjProp Object(%<\\_ObjId ")
          i        (1+ i)))
  (mapcar 'setvar (list 'cmdecho 'nomutt) (list 1 0))
  (prompt "\nSelect Net Area insertion point: ")
  (vla-addmtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                (vlax-3d-point (getpoint))
                0
                (strcat "%<\\AcExpr (%<\\AcObjProp Object(%<\\_ObjId "
                        (vl-string-right-trim "+%<\\AcObjProp Object(%<\\_ObjId " mtvalue1)
                        "%-%<\\AcObjProp Object(%<\\_ObjId "
                        (vl-string-right-trim "-%<\\AcObjProp Object(%<\\_ObjId " mtvalue2)
                        "%) \\f \"%lu2%pr1%ps[, m²]%ct8[1e-006]\">%"
                        " "
                        "%<\\AcExpr (%<\\AcObjProp Object(%<\\_ObjId "
                        (vl-string-right-trim "+%<\\AcObjProp Object(%<\\_ObjId " mtvalue1)
                        "%-%<\\AcObjProp Object(%<\\_ObjId "
                        (vl-string-right-trim "-%<\\AcObjProp Object(%<\\_ObjId " mtvalue2)
                        "%) \\f \"%lu2%qf1%pr0% ft²%ct8[1.076391041670998E-005]%th44\">%"
                )
  )
   (setq obj (vlax-ename->vla-object (entlast)))
   (vlax-put-property obj 'BackgroundFill :vlax-true)
   (mapcar 'setvar (list 'cmdecho 'nomutt) varlst)
   (command "justifytext" "L" "" "BL")
   (setvar "clayer" oldlayer)  ;restore old layer
   (setvar "cmdecho" 0)
   (command "move" "L" "" "d" "@0,250")
   (setvar "cmdecho" 1)
  (princ)
)
;;
;;
;;-------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

[wilsons3774183]

Thanks again Tom, This is fantastic.

Really appreciate your help with this.

Scott