area / permimeter script file

[s8utt]

thank you

 

you don't even believe how much time this will save

 

thanks once again

[Lee Mac]

You're welcome I learnt something from this thread, so we are both satisfied

[s8utt]

Lee I have a small mod to add if its possible.

 

I think I can also add weight by adding

 

Weight: %<\\AcObjProp Object(%<\\_ObjId "
                 (car Ids) ">%).Area \\f \"%lu2%ct8[0.00785]\">%"

 

this would add another line taking the area and multiple it by 0.00785

 

how would I ask the user to specify the density, but have 0.00785 as the default ( user can just press enter )

 

many thanks once again.

[Lee Mac]

Not a problem s8utt, give this a shot:

 

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

 (or *dens (setq *dens 0.00785))

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

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

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


 (princ "\nSelect Objects to Retrieve Total Area + Perimeter...")
 (if (and (ssget '((0 . "LINE,*POLYLINE")))
          (setq *dens (cond ((getreal (strcat "\nSpecify Density <" (rtos *dens) "> : "))) (*dens)))
          (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.

       (if (= 1 (length Ids))
         (strcat "Area: %<\\AcObjProp Object(%<\\_ObjId "
                 (car Ids) ">%).Area \\f \"%lu6%qf1\">%"
                 "\\PPerimeter: %<\\AcObjProp Object(%<\\_ObjId "
                 (car Ids) ">%).Length \\f \"%lu6\">%"
                 "\\PWeight: %<\\AcObjProp Object(%<\\_ObjId "
                 (car Ids) ">%).Area \\f \"%lu2%ct8[" (vl-princ-to-string *dens) "]\">%")
         
         (strcat "Area: %<\\AcExpr"
                 (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
                 ">%).Area >% \\f \"%lu6%qf1\">%"
                 "\\PPerimeter: %<\\AcExpr"
                 (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Length >% +")
                 ">%).Length >% \\f \"%lu6\">%"
                 "\\PWeight: %<\\AcExpr"
                 (lst->str Ids " %<\\AcObjProp Object(%<\\_ObjId " ">%).Area >% +")
                 ">%).Area >% \\f \"%lu2%ct8[" (vl-princ-to-string *dens) "]\">%")))
                 

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

 (princ))

[s8utt]

thanks once again, it worked flawlessly

 

I did change one line, it seems to work so I hope I did it correctly

 

(setq *dens (cond ((getreal (strcat "\nSpecify Density <" (rtos *dens 2 5) "> : "))) (*dens)))

 

I did this as the 0.00785 was being rounded and this would confuse some of the users.

 

Would it be possible to explode the code once its finished so that the values are not highlighted in grey.

 

I promise thats it, I feel I'm over stretching my ask for good will.

 

Its a fantastic bit of code.

[Lee Mac]

I did change one line, it seems to work so I hope I did it correctly

 

Nice one, yes, its correct. I wasn't sure how many to display it to, so I left the arguments out so that it would use your system settings.

 

Would it be possible to explode the code once its finished so that the values are not highlighted in grey.

 

I promise thats it, I feel I'm over stretching my ask for good will.

 

Its a fantastic bit of code.

 

You're welcome - it seems you are picking it up pretty quick

 

As for exploding the Fields, I'm not sure why you would want to do this, as the values won't update if the fields are exploded...

 

The grey background indicates that it is a field and can be toggles using the FIELDDISPLAY System Variable. (set to 0).

 

Lee

[s8utt]

well I love programming but AutoCad is completely new to me

 

know a bit of php,vb and python.

 

I guess its more frustrating as I know what I want and the logical statements to get there. I just don't know the commands yet.

 

Thanks for the fielddisplay, makes it look better.

 

If we alter the geometry we would normally explode the item, delete lines, add lines, re join. Therefore the object ID is lost.

I know your method is the 'correct' way to do it as the link is kept. The way our 'old' office works its better as a 'one shot' remove the link way.

 

Otherwise I can see people clicking on it and saying, err I don't like this the field no longer exists what is it on about.

 

The way they do this operation at minute is join the lines together, execute list, select object, write items down on piece of paper, create a new text item, type in contents. Then explode geometry.

 

So as you can see no need ( could say a hinderance ) to keep the field info linked.

 

Hopefully that explains it, my god I wish they would change but the little you start with today

 

Cheers

S8utt

[Lee Mac]

I don't have much CAD experience myself, but I always see advice on how it's bad practice to explode objects.

 

But from your reply, I can see that you would probably be better off without the field, and using just text/MText, am I right?

 

Lee

[s8utt]

yep your probably right

 

I just want some 'dumb' text thats populated with the areas etc

[Lee Mac]

Ok, try this:

 

(defun c:GetAP (/ *error* SumProp CONV DOC OBJS PROP PT SS SUMPROP UFLAG)
 (vl-load-com)
 ;; Lee Mac  ~  18.03.10

 (or *dens (setq *dens 0.00785))

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

 (setq SumProp (lambda (objects prop conv)
                 (apply (function +)
                        (mapcar (function (lambda (x)
                                            (* conv (vlax-get-property x prop)))) objects))))
 
 (princ "\nSelect Objects to Retrieve Total Area + Perimeter...")
 (if (and (ssget '((0 . "LINE,*POLYLINE")))
          (setq *dens (cond ((getreal (strcat "\nSpecify Density <" (rtos *dens 2 5) "> : "))) (*dens)))
          (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 Objs (cons obj Objs)))
     (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.

       (if (= 1 (length Objs))
         (strcat "Area: "         (rtos (vla-get-Area    (car Objs)))
                 "\\PPerimeter: " (rtos (vla-get-Length  (car Objs)))
                 "\\PWeight: "    (rtos (* (vla-get-Area (car Objs)) *dens)))
          
         (strcat "Area: "         (rtos (SumProp Objs 'Area 1.))
                 "\\PPerimeter: " (rtos (SUmProp Objs 'Length 1.))
                 "\\PWeight: "    (rtos (SumProp Objs 'Area *dens)))))              

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

 (princ))

[s8utt]

cracking, your a star.

 

thanks so much for all your help

[Lee Mac]

Not a problem mate

 

Lee

[kheajohn]

Hi Lee,

If you don't mind to make it getting the area in square meters, perimeter in meters via attribute as per selection just like you did in getting areas.

 

thanks,

Kheajohn

[Lee Mac]

To display the result at the command line:

 

(defun c:GetAP (/ *error* _Area _Perimeter ss )
 (vl-load-com)
 ;; © Lee Mac 2010

 (defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ)
 )

 (defun _Area      ( e ) (vlax-curve-getArea e))

 (defun _Perimeter ( e ) (vlax-curve-getDistatParam e (vlax-curve-getEndParam e)))

 (princ "\nSelect Objects to Retrieve Total Area + Perimeter...")
 (if (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE,LINE,*POLYLINE"))))
   (
     (lambda ( i area perim / e )
       (while (setq e (ssname ss (setq i (1+ i))))
         (setq area (+ area (_Area e)) perim (+ perim (_Perimeter e)))
       )

       (princ (strcat "\n:: Area = " (rtos area) "  Perimeter = " (rtos perim) " ::"))
     )
     -1 0.0 0.0
   )
 )

 (princ)
)

 

Added Circles, Arcs, Ellipses, Splines...

 

Lee

[rami_9630]

thanks Lee for the valuable code, i wonder if there is a way it can be modified to calculate the number of persons per area according to formula i can insert into code, lets say the maximum number of persons is 7 per 100 square meter, is there anyway this can be incorporated so the code display the area and number of persons as well.

 

hope im not asking for too much

[squowse]

Thanks a million Lee for the code.

 

To the poster above, what you have described can be achieved using the "density" option. All it does it multiply the measured area by the number given as density.

Edited May 15, 2013 by squowse