Automatic hatch based on polyline area ranges

Hi all

I'd like to be able to amend the below code to include the ability to automatically create hatch based on predefined area ranges of the polylines:

For example:

250m² to 299m² = solid hatch colour 150

300m² to 349m² = solid hatch colour 170

;; Written by PBEJSE on CADTutor
;; Post #4 https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/multiple-polyline-area-labels/td-p/3459894
;; Relies on TEXTSIZE variable for text size
;; 280316 - Tharwat updated field properties in post #2 in above link

(defun c:MFA  (/ BitVersion acsp ss e ptList ID StrField txt p)
(vl-load-com)      
     (setq BitVersion
                      (if (> (strlen
                                   (vl-prin1-to-string
                                         (vlax-get-acad-object)))
                             40) T nil)
           acsp       (vla-get-block
                            (vla-get-activelayout
                                  (vla-get-activedocument
                                        (vlax-get-acad-object)))))
     (if (setq ss (ssget "_X" '((0 . "*POLYLINE")
                       (8 . "UD-AREA-BDRY")
                       (-4 . "&")
                       (70 . 1)(410 . "Model"))))
     (repeat (sslength ss)
           (setq e     (ssname ss 0)
                 sum   '(0 0)
                 verts (cdr (assoc 90 (entget e))))
           (setq ptList
                      (mapcar 'cdr
                              (vl-remove-if-not
                                    '(lambda (x) (= (car x) 10))
                                    (entget e))))
           (foreach x ptList (setq sum (mapcar '+ x sum)))
           (setq ID   (if BitVersion
                            (vlax-invoke-method
                                  (vla-get-Utility
                                        (vla-get-ActiveDocument
                                              (vlax-get-acad-object)))
                                  'GetObjectIdString
                                  (vlax-ename->vla-object
                                        e)
                                  :vlax-False)
                            (itoa (vla-get-objectid
                                        (vlax-ename->vla-object e)))))
           (setq StrField
                      (strcat
                            "%<\\AcObjProp Object(%<\\_ObjId " id ">%).Area \\f \"%lu2%pr0%ps[, m²]%ds44\">%"))
           (vla-put-AttachmentPoint
                 (setq txt (vla-addMText
                                 acsp
                                 (setq p (vlax-3d-point
                                                  (mapcar '/ sum
                                                        (list verts
                                                              verts))))
                                 0  StrField))
                 acAttachmentPointMiddleCenter)
           (vla-put-InsertionPoint txt p)
           (ssdel e ss)
           )(princ "\0 Objects found:"))
     (princ)
     )

Thanks

Paul

Hi Paul,

Add the following codes and don't forget to localize the variables (ar clr c) and I am sure that you know where to place the codes.

[uNTESTED CODES]

       (setq c nil clr (getvar 'CECOLOR))
       (cond ((< 251 (setq ar (read (rtos (vla-get-area (vlax-ename->vla-object e)) 2 0))) 300)(setq c 150))
             ((< 301 ar 350)(setq c 170))
             )
       (if c (setvar 'CECOLOR (itoa c)))
       (command "_.-HATCH" "_P" "SOLID" "_S" e "" "")
       (setvar 'CECOLOR clr)

Hi Tharwat,

I just tested it, since the OP works in mm you must multiply the "ar" variable by 100 000 to get it in sq.m.

EDIT:

Something like this, with (ar clr c mp) as arguments.

(setq c nil clr (getvar 'CECOLOR))
(setq ar (read (rtos (vla-get-area (vlax-ename->vla-object e)) 2 0)))
(cond
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 4) (setq mp 100000) ) )
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 5) (setq mp 10000) ) )
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 6) (setq mp 1000) ) )
( (= (getvar 'INSUNITS) 4) (setq mp 100000) ) ; multiplier milimeters
( (= (getvar 'INSUNITS) 5) (setq mp 10000) ) ; multiplier centimeters
( (= (getvar 'INSUNITS) 6) (setq mp 1000) ) ; multiplier meters
);cond
(cond 
((< (* 251 mp) ar (* 300 mp) )(setq c 150))
((< (* 301 mp) ar (* 350 mp) )(setq c 170))
);cond
(if c (setvar 'CECOLOR (itoa c)))
(command "_.-HATCH" "_P" "SOLID" "_S" e "" "")
(setvar 'CECOLOR clr)

I was not correct: not the "ar" variable to be multiplied, but the values for the range.

don't forget to localize the variables (ar clr c)

Done - but not sure where the ar variable is referenced in the original code

and I am sure that you know where to place the codes.

...not really but I'll do some trialling and testing

Thanks Grrr. I'll have a try with your code tonight

Hi Tharwat,

I just tested it, since the OP works in mm you must multiply the "ar" variable by 100 000 to get it in sq.m.

EDIT:

Something like this, with (ar clr c mp) as arguments.

(cond
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 4) (setq mp 100000) ) )
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 5) (setq mp 10000) ) )
( (= (getvar 'INSUNITS) 0) (if (= (getvar 'INSUNITSDEFTARGET) 6) (setq mp 1000) ) )
( (= (getvar 'INSUNITS) 4) (setq mp 100000) ) ; multiplier milimeters
( (= (getvar 'INSUNITS) 5) (setq mp 10000) ) ; multiplier centimeters
( (= (getvar 'INSUNITS) 6) (setq mp 1000) ) ; multiplier meters
);cond

I was not correct: not the "ar" variable to be multiplied, but the values for the range.

I am not sure you are right! since the rtos function would squeeze the number into meters and not Millimeters.

You cond function is not correct, replace if function with and function to wrap the first statement as well, and assign the system variable to a variable instead of getting it each time the expression not meet the criteria.

Done - but not sure where the ar variable is referenced in the original code

I highlighted the variable 'ar' in the following updated program.

...not really but I'll do some trialling and testing

Not a problem, try this;

(defun c:MFA (/ BitVersion acsp ss e ptList ID StrField txt p [color="red"]ar c clr sum verts[/color])      
     (setq BitVersion (if (> (strlen (vl-prin1-to-string (vlax-get-acad-object))) 40) T nil)
           acsp       (vla-get-block (vla-get-activelayout (vla-get-activedocument
                                                             (vlax-get-acad-object)))))
     (if (setq ss (ssget "_X" '((0 . "*POLYLINE") (8 . "UD-AREA-BDRY") (-4 . "&") (70 . 1)(410 . "Model"))))
       (repeat (sslength ss)
         (setq e     (ssname ss 0)
               sum   '(0 0)
               verts  (cdr (assoc 90 (entget e))))
         (setq ptList (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))))
         (foreach x ptList (setq sum (mapcar '+ x sum)))
         (setq ID   (if BitVersion (vlax-invoke-method  (vla-get-Utility (vla-get-ActiveDocument
                                                                           (vlax-get-acad-object)))
                                     'GetObjectIdString (vlax-ename->vla-object e) :vlax-False)
                      (itoa (vla-get-objectid (vlax-ename->vla-object e))))
               StrField (strcat  "%<\\AcObjProp Object(%<\\_ObjId " id ">%).Area \\f \"%lu2%pr0%ps[, m²]%ds44\">%")
               txt (vla-addMText acsp (setq p (vlax-3d-point (mapcar '/ sum (list verts verts)))) 0  StrField)
               )
           (vla-put-AttachmentPoint txt  acAttachmentPointMiddleCenter)
         (vla-put-InsertionPoint txt p)
         (setq c nil clr (getvar 'CECOLOR))
       (cond ((< 251 (setq [color="red"][b]ar[/b][/color] (read (rtos (vla-get-area (vlax-ename->vla-object e)) 2 0))) 300)(setq c 150))
             ((< 301 ar 350)(setq c 170))
             )
       (if c (setvar 'CECOLOR (itoa c)))
       (command "_.-HATCH" "_P" "SOLID" "_S" e "" "")
       (setvar 'CECOLOR clr)
           (ssdel e ss)
           )(princ "\0 Objects found:"))
     (princ)
     )(vl-load-com)

I highlighted the variable 'ar' in the following updated program.

 

Not a problem, try this

Thanks Tharwat. That works well and puts the area text in pretty quickly and

hatches all the closed polylines - but the hatch is on layer zero and not coloured

I've added some code in (coloured blue) to set the area text size. This works well. I've also added some code in (coloured red) to set the hatch layer so that each different coloured hatch is on a different layer - but this gives a syntax error so I've commented it out.

This is what I have now:

;; Written by PBEJSE on CADTutor
;; Post #4 https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/multiple-polyline-area-labels/td-p/3459894
;; Relies on TEXTSIZE variable for text size
;; 280316 - Tharwat updated field properties in post #2 in above link
;; 040416 - Tharwat updated to add hatch based on area ranges

(command "-dimstyle" "R" "Urbis")

(defun c:MFAH (/ BitVersion acsp ss e ptList ID StrField txt p ar c clr sum verts)      
     
[color="deepskyblue"](setq ins (getvar "insunits"))
   
(cond
((= (setq ins (getvar "insunits")) 4) ;if insunits=4 then apply 1 x cannoscale
(setvar "dimscale" (/ 1.0 (getvar "CANNOSCALEVALUE"))))
((= ins 6) ;if insunits=6 then apply 0.001 x cannoscale
(setvar "dimscale" (/ 0.001 (getvar "CANNOSCALEVALUE"))))
)

(setq scale (getvar "DIMSCALE"))
(setq ln (strcat "L-TEXT-AREA-"(rtos scale 2 0)))
(command "-LAYER" "m" ln "co" "7" ln "p" "p" ln "")

(setvar "TEXTSTYLE" "Standard") 
(setvar "TEXTSIZE" (* 1.8(getvar "DIMSCALE")))
[/color]
[color="red"];(if (not (or (tblsearch "LAYER" "U-AREA-HTCH-BDRY")))) 
;             (tblsearch "LAYER" "U-AREA-HTCH")
         
;(progn
;(command "-layer" "Make" "U-AREA-HTCH-BDRY" "Plot" "No" "" "Colour" "6" "" "description" "Area Hatch Boundary" "U-AREA-HTCH-BDRY" "")
;(command "-layer" "Make" "U-AREA-HTCH" "Colour" "254" "" "description" "AREA Hatch" "U-AREA-HTCH" "")
[/color]


(setq BitVersion (if (> (strlen (vl-prin1-to-string (vlax-get-acad-object))) 40) T nil)
           acsp       (vla-get-block (vla-get-activelayout (vla-get-activedocument
                                                             (vlax-get-acad-object)))))
     (if (setq ss (ssget "_X" '((0 . "*POLYLINE") (8 . "U-AREA-HTCH-BDRY") (-4 . "&") (70 . 1)(410 . "Model"))))
       (repeat (sslength ss)
         (setq e     (ssname ss 0)
               sum   '(0 0)
               verts  (cdr (assoc 90 (entget e))))
         (setq ptList (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget e))))
         (foreach x ptList (setq sum (mapcar '+ x sum)))
         (setq ID   (if BitVersion (vlax-invoke-method  (vla-get-Utility (vla-get-ActiveDocument
                                                                           (vlax-get-acad-object)))
                                     'GetObjectIdString (vlax-ename->vla-object e) :vlax-False)
                      (itoa (vla-get-objectid (vlax-ename->vla-object e))))
               StrField (strcat  "%<\\AcObjProp Object(%<\\_ObjId " id ">%).Area \\f \"%lu2%pr0%ps[, m²]%ds44\">%")
               txt (vla-addMText acsp (setq p (vlax-3d-point (mapcar '/ sum (list verts verts)))) 0  StrField)
               )
           (vla-put-AttachmentPoint txt  acAttachmentPointMiddleCenter)
         (vla-put-InsertionPoint txt p)
         (setq c nil clr (getvar 'CECOLOR))
       (cond ((< 251 (setq ar (read (rtos (vla-get-area (vlax-ename->vla-object e)) 2 0))) 300)(setq c 150))
             ((< 301 ar 350)(setq c 170))
             )
       (if c (setvar 'CECOLOR (itoa c)))

       (command "_.-HATCH" "_P" "SOLID" "_S" e "" "")
       (setvar 'CECOLOR clr)
           (ssdel e ss)
           )(princ "\0 Objects found:"))
     (princ)
     )(vl-load-com)

Thanks

Paul

Check from command line -layer and watch the prompts you need to repeat the layer name in nearly every option

"m" "U-AREA-HTCH-BDRY" "c" 6 "U-AREA-HTCH-BDRY"

My $0.05 the area is really irrelevant wether its hectatres, metres, sq feet or acres just adjust the cond between this range and that range. 1 -10000 1-100 etc

Check from command line -layer and watch the prompts you need to repeat the layer name in nearly every option

Is this the code you mean? I've tested this and works as expected.

(progn
(command "-layer" "Make" "U-AREA-HTCH-BDRY" "Plot" "No" "" "Colour" "6" "" "description" "Area Hatch Boundary" "U-AREA-HTCH-BDRY" "")
(command "-layer" "Make" "U-AREA-HTCH" "Colour" "254" "" "description" "AREA Hatch" "U-AREA-HTCH" "")
)

My $0.05 the area is really irrelevant wether its hectatres, metres, sq feet or acres just adjust the cond between this range and that range. 1 -10000 1-100 etc

Agree - for the area value the units is not relevant. I'm only using the units to determine text size

I am not sure you are right! since the rtos function would squeeze the number into meters and not Millimeters.

I didn't knew that!

You cond function is not correct, replace if function with and function to wrap the first statement as well, and assign the system variable to a variable instead of getting it each time the expression not meet the criteria.

Thanks for the hint! I completely forgot about and function.

Anyways nice code and good job, Tharwat!