Create Area that updates with moving a dimension

I am trying to create and text object that calculates the area from to autocad dimensions and automatically updates when you change the dimension. It is for head spacing in sprinkler drawings and calculating the area served. So if I move the head the area updates. I looked at fields and rectors but am at a loss. Any suggestions or links? I can do field with the area of an object but I am trying to do one where the lisp selects two dimensions and updates when the dimension changes.

I would use a FIELD, see here perhaps;

http://www.cadtutor.net/forum/showthread.php?t=46628

There is a link in that thread also to a LISP I wrote recently which may help you.

Lee

Thanks yet again. I searched all over this forum for that. I was able to modify it to do my bidding!

How do I make the text field middle center justify? I am wanting to use tcircle to draw a box around it and if it changes size middle justification will work.

Also when I add this to the lisp routine it doesn't work either. Nothing is ever easy with this stuff.

(command "tcircle" "last" "" ".035" "r" "v")

;;                                                                               ;;
;;  AUTHOR:                                                                      ;;
;;                                                                               ;;
;;  Copyright © Lee McDonnell, April 2010. All Rights Reserved.                  ;;
;;                                                                               ;;
;;      { Contact: Lee Mac @ TheSwamp.org, CADTutor.net }                        ;;
;;                                                                               ;;
 (defun c:hsw (/ *error* lst->str DOC IDS PT SS UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10

 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun GetObjectID (obj)
   (setq util (cond (util) ((vla-get-Utility
                              (vla-get-ActiveDocument (vlax-get-acad-object))))))
   
   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))     

 (defun lst->str (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))

 (princ "\nSelect Objects to Retrieve Total Area... ")
;Modified by MandDarran to change text and dimension
 (if (and (ssget '((0 . "DIMENSION")))
 
 ;;,ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))
   
   (setq pt (getpoint "\nPick Point for Field: ")))
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)

     (vla-AddMText

       (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
               (eq :vlax-true   (vla-get-MSpace doc)))
         (vla-get-ModelSpace doc)
         (vla-get-PaperSpace doc))

       (vlax-3D-point pt) 0.

;Modified by MandDarran to change text and dimension
       (if (= 1 (length Ids))
         (strcat "%<\\AcObjProp Object(%<\\_ObjId " (car Ids) ">%).Measurement \\f \"%lu6%qf1\">%")
         (strcat "%<\\AcExpr" (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Measurement >% *")
                 ">%).Measurement >% \\f \"%lu2%pr0\"/144*4>%")))


     (setq uFlag (vla-EndUndomark doc))))

 (princ))
 

Hi Matt,

Happy to help, on a side note, I would appreciate it if you noted that you have modified the routine, and at which points - this is common coding courtesy

(defun c:hsw (/ *error* lst->str DOC IDS PT SS UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10

 (defun *error* (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun GetObjectID (obj)
   (setq util (cond (util) ((vla-get-Utility
                              (vla-get-ActiveDocument (vlax-get-acad-object))))))
   
   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))     

 (defun lst->str (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))

 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "DIMENSION")))
 
 ;;,ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))
   
   (setq pt (getpoint "\nPick Point for Field: ")))
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))
     
     (vlax-for obj (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)

     (vla-put-AttachmentPoint
       
       (vla-AddMText

         (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
                 (eq :vlax-true   (vla-get-MSpace doc)))
           (vla-get-ModelSpace doc)
           (vla-get-PaperSpace doc))

         (vlax-3D-point pt) 0.
         (if (= 1 (length Ids))
           (strcat "%<\\AcObjProp Object(%<\\_ObjId " (car Ids) ">%).Measurement \\f \"%lu6%qf1\">%")
           (strcat "%<\\AcExpr" (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Measurement >% *")
                   ">%).Measurement >% \\f \"%lu2%pr0\"/144*4>%")))

       acAttachmentPointMiddleCenter)


     (setq uFlag (vla-EndUndomark doc))))

 (princ))

^^ That should work for Centre Justification.

Sure. Sorry. I just copied and pasted.....

Done. I just copied the lisp from the other post and it didn't have your fancy header. Copied and pasted and updated. Sorry about that.

Minor revision so the text will remain at specified point (moves when Justification changed).

(defun c:hsw  (/ *error* lst->str DOC IDS PT SS UFLAG mTxt)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10

 (defun *error*  (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun GetObjectID  (obj)
   (setq util (cond (util)
                    ((vla-get-Utility
                       (vla-get-ActiveDocument (vlax-get-acad-object))))))

   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))

 (defun lst->str  (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))

 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "DIMENSION")))

          ;;,ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))

          (setq pt (getpoint "\nPick Point for Field: ")))
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))

     (vlax-for obj  (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)

     (vla-put-AttachmentPoint

       (setq mTxt (vla-AddMText ; alanjt

                    (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
                            (eq :vlax-true (vla-get-MSpace doc)))
                      (vla-get-ModelSpace doc)
                      (vla-get-PaperSpace doc))

                    (vlax-3D-point pt)
                    0.
                    (if (= 1 (length Ids))
                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                              (car Ids)
                              ">%).Measurement \\f \"%lu6%qf1\">%")
                      (strcat "%<\\AcExpr"
                              (lst->str Ids
                                        " %<\\AcObjProp Object(%<\\_ObjId "
                                        ">%).Measurement >% *")
                              ">%).Measurement >% \\f \"%lu2%pr0\"/144*4>%"))))

       acAttachmentPointMiddleCenter)

     [color=Red](vla-put-InsertionPoint mTxt (vlax-3D-point pt)) ; alanjt[/color]


     (setq uFlag (vla-EndUndomark doc))))

 (princ))

Nice code BTW.

Thanks Alan

Done. I just copied the lisp from the other post and it didn't have your fancy header. Copied and pasted and updated. Sorry about that.

It wasn't the header I was worried about (but thanks for that anyway), it was more the noted changes.

A semi "Tcircle" solution is here for other people following this thread:

http://www.cadtutor.net/forum/showthread.php?t=32685&highlight=tcircle

I am now going to search and see if it is easier to just put the field inside and attribute block instead of a mtext object.

A semi "Tcircle" solution is here for other people following this thread:

 

http://www.cadtutor.net/forum/showthread.php?t=32685&highlight=tcircle

 

I am now going to search and see if it is easier to just put the field inside and attribute block instead of a mtext object.

I've suggested the script method Jammie showed before, but I found that vla-sendcommand is a little easier to work with.

I posted a solution in the other thread...

http://www.cadtutor.net/forum/showpost.php?p=316572&postcount=25

Another way to BoxObjects

(defun BoxObject (obj / MakeSafearrayVariant LWPoly
                       GetBoundingBox GetActiveSpace ll ur)
 ;; Lee Mac  ~  09.04.10

 (defun MakeSafearrayVariant (typ val)
   (vlax-make-variant
     (vlax-safearray-fill
       (vlax-make-safearray (eval typ)
         (cons 1 (length val))) val)))

 (defun AddClosedLWPoly (block lst)
   (vla-put-Closed
     (setq o (vla-AddLightWeightPolyline block
               (MakeSafearrayVariant vlax-VbDouble
                 (apply (function append)
                        (mapcar
                          (function
                            (lambda (x)
                              (list (car x) (cadr x)))) lst))))) :vlax-true)
   o)

 (defun GetBoundingBox (ll ur / data)
   (  (lambda (data)         
      (mapcar
        (function
          (lambda (funcs)
            (mapcar
              (function
                (lambda (func)
                  ((eval func) data))) funcs)))

        '((caar   cadar) (caadr  cadar)
          (caadr cadadr) (caar  cadadr))))

     (mapcar (function vlax-safearray->list) (list ll ur))))

 (defun GetActiveSpace (doc)
   (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)))

 (vla-GetBoundingBox obj 'll 'ur)
 (AddClosedLWPoly
   (GetActiveSpace
     (vla-get-ActiveDocument
       (vlax-get-acad-object))) (GetBoundingBox ll ur)))

With Offset

(defun BoxObject (obj offset / MakeSafearrayVariant LWPoly
                              GetBoundingBox GetActiveSpace ll ur)
 ;; Lee Mac  ~  09.04.10

 (defun MakeSafearrayVariant (typ val)
   (vlax-make-variant
     (vlax-safearray-fill
       (vlax-make-safearray (eval typ)
         (cons 1 (length val))) val)))

 (defun AddClosedLWPoly (block lst / o)
   (vla-put-Closed
     (setq o (vla-AddLightWeightPolyline block
               (MakeSafearrayVariant vlax-VbDouble
                 (apply (function append)
                        (mapcar
                          (function
                            (lambda (x)
                              (list (car x) (cadr x)))) lst))))) :vlax-true)
   o)

 (defun GetBoundingBox (ll ur o / data)
   (  (lambda (data)         
      (mapcar
        (function
          (lambda (funcs)
            (mapcar
              (function
                (lambda (func)
                  ((eval func) data))) funcs)))

        '(((lambda (x) (- (caar  x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (+ (cadadr x) o)))
          ((lambda (x) (- (caar  x) o)) (lambda (x) (+ (cadadr x) o))))))

     (mapcar (function vlax-safearray->list) (list ll ur))))

 (defun GetActiveSpace (doc)
   (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)))

 (vla-GetBoundingBox obj 'll 'ur)
 (AddClosedLWPoly
   (GetActiveSpace
     (vla-get-ActiveDocument
       (vlax-get-acad-object))) (GetBoundingBox ll ur offset)))

 

You've inspired me Lee!

(defun c:Encircle (/ ss p1 p2 pMid)
 ;; Alan J. Thompson, 04.09.10
 (and (setq ss (ssget '((0 . "MTEXT,TEXT"))))
      ((lambda (i)
         (while (setq e (ssname ss (setq i (1+ i))))
           (vla-getboundingbox (vlax-ename->vla-object e) 'p1 'p2)
           (entmakex (list '(0 . "CIRCLE")
                           '(100 . "AcDbEntity")
                           '(100 . "AcDbCircle")
                           (cons 10
                                 (setq pMid (mapcar (function (lambda (a b) (/ (+ a b) 2.)))
                                                    (setq p1 (vlax-safearray->list p1))
                                                    (setq p2 (vlax-safearray->list p2))
                                            )
                                 )
                           )
                           (cons 40 (+ (cdr (assoc 40 (entget e))) (distance pMid p1)))
                     )
           )
         )
       )
        -1
      )
 )
 (princ)
)

Happy to be of service.

Subroutine form:

(defun Encircle (e / p1 p2 pMid)
 ;; Alan J. Thompson, 04.09.10
 (if (eq (type e) 'VLA-OBJECT)
   (progn
     (vla-getboundingbox e 'p1 'p2)
     (vlax-ename->vla-object
       (entmakex (list '(0 . "CIRCLE")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbCircle")
                       (cons 10
                             (setq pMid (mapcar (function (lambda (a b) (/ (+ a b) 2.)))
                                                (setq p1 (vlax-safearray->list p1))
                                                (setq p2 (vlax-safearray->list p2))
                                        )
                             )
                       )
                       (cons 40 (+ (vla-get-Height e) (distance pMid p1)))
                 )
       )
     )
   )
 )
)

You guys are amazing.

Is there an easy way to insert a block with an attribute that contains field instead of inserting mtext and then drawing a box around it? Seems that might be better as if I need to move it when I move the head I only have select one object instead of two.

I added this (BoxObject obj 0.35) to the lisp above (princ) to do before it exits and placed the BoxObject program in there as well and I get this when I run it.

** Error: Automation Error. Object was erased **

I shall have a look, in the mean time, here is another to play with

;; Obj     => VLA-Object
;; Offset  => Real
;; Mode    => Integer
;; 0 = Rectangle, 1 = Circle, 2 = Slot

(defun BoxObject (obj offset Mode / MakeSafearrayVariant LWPoly
                                   GetBoundingBox GetActiveSpace ll ur c p)
 ;; Lee Mac  ~  09.04.10

 (defun MakeSafearrayVariant (typ val)
   (vlax-make-variant
     (vlax-safearray-fill
       (vlax-make-safearray (eval typ)
         (cons 1 (length val))) val)))

 (defun AddClosedLWPoly (block lst / o)
   (vla-put-Closed
     (setq o (vla-AddLightWeightPolyline block
               (MakeSafearrayVariant vlax-VbDouble
                 (apply (function append)
                        (mapcar
                          (function
                            (lambda (x)
                              (list (car x) (cadr x)))) lst))))) :vlax-true)
   o)

 (defun AddCircle (block cen rad)
   (vla-AddCircle block (vlax-3D-point cen) rad))

 (defun GetBoundingBox (ll ur o / data)
   (  (lambda (data)         
      (mapcar
        (function
          (lambda (funcs)
            (mapcar
              (function
                (lambda (func)
                  ((eval func) data))) funcs)))

        '(((lambda (x) (- (caar  x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (+ (cadadr x) o)))
          ((lambda (x) (- (caar  x) o)) (lambda (x) (+ (cadadr x) o))))))

     (mapcar (function vlax-safearray->list) (list ll ur))))

 (defun GetActiveSpace (doc)
   (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)))

 (vla-GetBoundingBox obj 'll 'ur)
 (setq bb (GetBoundingBox ll ur offset))

 (cond (  (or (= 0 Mode) (= 2 Mode))

          (setq p (AddClosedLWPoly
                    (GetActiveSpace
                      (vla-get-ActiveDocument
                        (vlax-get-acad-object))) bb))

          (if (= 2 Mode)
            (mapcar (function (lambda (v) (vla-SetBulge p v 1.))) '(1 3))) p)

       (  (AddCircle
            (GetActiveSpace
              (vla-get-ActiveDocument
                (vlax-get-acad-object)))

            (setq c (append (mapcar (function /)
                                    (apply (function mapcar)
                                           (cons (function +) bb))
                                    '(4. 4.))
                            '(0.)))

            (distance c (car bb))))))



(defun c:test (/ l ss o m)
 (vl-load-com)
 (setq l '("Rectangle" "Circle" "Slot"))
 
 (if (and (setq ss (ssget))
          (setq o  (getdist "\nOffset? : ")))
   (progn
     (initget 1 "Rectangle Circle Slot")
     (setq m (vl-position (getkword "\nBox With [Rectangle/Circle/Slot]: ") l))

     (  (lambda (count)
          (while (setq e (ssname ss (setq count (1+ count))))
            (BoxObject (vlax-ename->vla-object e) o m))) -1)))
 (princ))

Try this:

(defun c:hsw  (/ *error* lst->str DOC IDS PT SS UFLAG mTxt)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10

 (defun *error*  (msg)
   (and uFlag (vla-EndUndomark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (defun GetObjectID  (obj)
   (setq util (cond (util)
                    ((vla-get-Utility
                       (vla-get-ActiveDocument (vlax-get-acad-object))))))

   (if (vl-string-search "X64" (strcase (getvar 'PLATFORM)))
     (vlax-invoke-method util 'GetObjectIdString obj :vlax-false)
     (itoa (vla-get-Objectid obj))))

 (defun lst->str  (lst d1 d2)
   (if (cdr lst)
     (strcat d1 (car lst) d2 (lst->str (cdr lst) d1 d2))
     (strcat d1 (car lst))))

 (princ "\nSelect Objects to Retrieve Total Area... ")
 (if (and (ssget '((0 . "DIMENSION")))

          ;;,ARC,CIRCLE,ELLIPE,HATCH,*POLYLINE,REGION")))

          (setq pt (getpoint "\nPick Point for Field: ")))
   (progn
     (setq uFlag (not (vla-StartUndoMark
                        (setq doc (vla-get-ActiveDocument
                                    (vlax-get-acad-object))))))

     (vlax-for obj  (setq ss (vla-get-ActiveSelectionSet doc))
       (setq Ids (cons (GetObjectID obj) Ids)))
     (vla-delete ss)

     (vla-put-AttachmentPoint

       (setq mTxt (vla-AddMText ; alanjt

                    (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
                            (eq :vlax-true (vla-get-MSpace doc)))
                      (vla-get-ModelSpace doc)
                      (vla-get-PaperSpace doc))

                    (vlax-3D-point pt)
                    0.
                    (if (= 1 (length Ids))
                      (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                              (car Ids)
                              ">%).Measurement \\f \"%lu6%qf1\">%")
                      (strcat "%<\\AcExpr"
                              (lst->str Ids
                                        " %<\\AcObjProp Object(%<\\_ObjId "
                                        ">%).Measurement >% *")
                              ">%).Measurement >% \\f \"%lu2%pr0\"/144*4>%"))))

       acAttachmentPointMiddleCenter)

     (vla-put-InsertionPoint mTxt (vlax-3D-point pt)) ; alanjt

     (BoxObject mTxt 0.35)    

     (setq uFlag (vla-EndUndomark doc))))

 (princ))


(defun BoxObject (obj offset / MakeSafearrayVariant LWPoly
                              GetBoundingBox GetActiveSpace ll ur)
 ;; Lee Mac  ~  09.04.10

 (defun MakeSafearrayVariant (typ val)
   (vlax-make-variant
     (vlax-safearray-fill
       (vlax-make-safearray (eval typ)
         (cons 1 (length val))) val)))

 (defun AddClosedLWPoly (block lst / o)
   (vla-put-Closed
     (setq o (vla-AddLightWeightPolyline block
               (MakeSafearrayVariant vlax-VbDouble
                 (apply (function append)
                        (mapcar
                          (function
                            (lambda (x)
                              (list (car x) (cadr x)))) lst))))) :vlax-true)
   o)

 (defun GetBoundingBox (ll ur o / data)
   (  (lambda (data)         
      (mapcar
        (function
          (lambda (funcs)
            (mapcar
              (function
                (lambda (func)
                  ((eval func) data))) funcs)))

        '(((lambda (x) (- (caar  x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (- (cadar  x) o)))
          ((lambda (x) (+ (caadr x) o)) (lambda (x) (+ (cadadr x) o)))
          ((lambda (x) (- (caar  x) o)) (lambda (x) (+ (cadadr x) o))))))

     (mapcar (function vlax-safearray->list) (list ll ur))))

 (defun GetActiveSpace (doc)
   (if (or (eq AcModelSpace (vla-get-ActiveSpace doc))
           (eq :vlax-true   (vla-get-MSpace doc)))
     (vla-get-ModelSpace doc)
     (vla-get-PaperSpace doc)))

 (vla-GetBoundingBox obj 'll 'ur)
 (AddClosedLWPoly
   (GetActiveSpace
     (vla-get-ActiveDocument
       (vlax-get-acad-object))) (GetBoundingBox ll ur offset)))