Area Field LISP by Lee Mac to mod

karpki · ‎03-18-2021

Hi,

I use AFM Lisp made by Lee Mac to label areas by picking hatches (most often scenario)

How to mod the code (add some lines ?) so it will check all hatches in the drawing and place such label in the middle of each hatch by one click ?

Thanks in advance!

Regards

Kirill

ВeekeeCZ · ‎03-18-2021

Found this in my archive. You can play with part commented out if you want.

(vl-load-com)

(defun c:PLArea  (/ adoc acsp ss e ptList ID StrField txt p)
  
  (setq  acsp (vla-get-modelspace (setq adoc (vla-get-activedocument (vlax-get-acad-object)))))
  (vla-startundomark adoc)
  (if (setq ss (ssget ;(progn
			;(initget 1 "Y N")
                        ;(setq ans (getkword "\nProcess All Polylines [Yes/No]: "))
			;(if (eq "Y" ans)
			  ;"_X"
			  ":L";))
		      '((-4 . "<OR")
                        	(0 . "CIRCLE")
                        	(-4 . "<AND")
                        		(0 . "*POLYLINE")
                        		(-4 . "&")
                        		(70 . 1)
                        	(-4 . "AND>")
                        (-4 . "OR>")	
                        )))
    (repeat (sslength ss)
            (setq e     (ssname ss 0)
                  sum   '(0 0)
                  verts (cond ((cdr (assoc 90 (entget e))))
                              (1)))
            (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 (itoa (vla-get-objectid (vlax-ename->vla-object e))))
            (setq StrField (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                                   ID
                                   ">%).Area \\f \"%lu2\">%"))
            (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 "\n0 Objects found:"))
  (vla-endundomark adoc)
  (princ)
)

karpki · ‎03-18-2021

Thank you!

The code itself works

And yes I will "play" trying to adjust it for my tasks.

Good!

Will be back

Regards

K

braudpat · ‎03-19-2021

Hello @karpki

An other beautiful Area Routine from (gile) !

PolyArea runs on many entities : ALL 2D PLines, Circles, Ellipses, Regions, etc ...

If you want to run ONLY on Closed PLines you can modify the Code !

You have BOTH Filters ... Comment / UnComment ...

You can easily change the code : number of decimals, suffix, ...

Thanks to Gilles (gile) !

The Health, Bye, Patrice

Patrice ( Supporting Troops ) - Autodesk Expert Elite
If you are happy with my answer please mark "Accept as Solution" and if very happy please give me a Kudos (Felicitations) - Thanks

Patrice BRAUD

karpki · ‎03-19-2021

Hi

Changed your lisp little bit, so it works with hatches without asking Y or N, just one click

BUT can't handle that label appears quite away of the hatch

Could you pls correct it ?

ВeekeeCZ · ‎03-19-2021

The thing with HATCH different from LWPOLYLINEs is that you need to omit the first 'vertex'.

Btw, the algorithm of center calculation is really simple, so if you have some odd shape it goes to hell anyway. Don't rely on it.

(setq ptList (cdr (reverse (cdr (mapcar 'cdr
                                 (vl-remove-if-not
                                   '(lambda (x)
                                      (= (car x) 10))
                                   (entget e)))))))

Edit: Last one too.

karpki · ‎03-19-2021

Hi and thank you!!!

I tried to modify this code for hatches but unfortunately it wasn't successfully

Could you please help?

BR
K

ВeekeeCZ · ‎03-19-2021

See the edit.

btw you can try yourself what vertices you've got to work with:

(mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel)))))

copy/paste it into the command-line.

karpki · ‎03-19-2021

Shapes are quite simple in test file, see area 1 below

Hatches have their centers inside areas

But labels are in hell, yes, see area 2 below

adding (cdr................) didn't effect unfortunately

karpki · ‎03-19-2021

ok , testing next edit in process

karpki · ‎03-19-2021

no effect

again same picture

karpki · ‎03-19-2021

test file

ВeekeeCZ · ‎03-19-2021

Ok.. your layer def is bad. Also we need to fix no of vertices.

;; Z9E3zK5E
;; Đ˛ ĐľŃ‚Đ˛ĐµŃ‚: karpki
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/area-field-lisp-by-lee-mac-to-mod/td-p/10167964


(vl-load-com)

(defun c:AFM2  (/ adoc acsp ss e ptList ID StrField txt p)
  
  (command "_style" "ISOCPEUR" "ISOCPEUR" "500" "" "" "" "")
  (command "_layer" "_m" "_Areas" "_Color" "7" "" "")
  
  (setq  acsp (vla-get-modelspace (setq adoc (vla-get-activedocument (vlax-get-acad-object)))))
  (vla-startundomark adoc)
  (if (setq ss (ssget "_A" '(( 0 . "HATCH"))))
    (repeat (sslength ss)
      (setq e    (ssname ss 0)
	    sum   '(0 0)
	    ptList (cdr (reverse (cdr (mapcar 'cdr
			   (vl-remove-if-not
			     '(lambda (x)
				(= (car x) 10))
			     (entget e))))))
	    verts (length ptList))
      (foreach x ptList (setq sum (mapcar '+ x sum)))
      (setq ID (itoa (vla-get-objectid (vlax-ename->vla-object e))))
      (setq StrField (strcat "%<\\AcObjProp Object(%<\\_ObjId "
			     ID
			     ">%).Area \\f \"%lu2%pr1%ps[, m\\\\U+00B2]%ct8[1.0E-006]\">%"))
      (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 "\n0 Objects found:"))
  (vla-endundomark adoc)
  (princ)
  )

karpki · ‎03-19-2021

The code (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (car (entsel))))) in command line ask me to select the object, after picking the hatch result tells me nothing talking true

karpki · ‎03-19-2021

Much better, almost perfect !

What do you think abt more difficult hatch with the "column" see screenshot below

Can this be fixed ?

karpki · ‎03-19-2021

"_Areas"

is one of my working layer always presented in drawing

that's why I use "_s"

braudpat · ‎03-19-2021

Hello @ВeekeeCZ

I like this :

\\\\U+00B2

The Health, Bye, Patrice

Patrice ( Supporting Troops ) - Autodesk Expert Elite
If you are happy with my answer please mark "Accept as Solution" and if very happy please give me a Kudos (Felicitations) - Thanks

Patrice BRAUD

ВeekeeCZ · ‎03-20-2021

@karpki wrote:

Much better, almost perfect !

What do you think abt more difficult hatch with the "column" see screenshot below

Can this be fixed ?

Ok, it was enough of hatch vertices, here's another method.

(vl-load-com)
(defun c:AFM2 ( / *error* doc msp stl s i e o p m ll ur)
  
  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
      (princ (strcat "\nError: " errmsg)))
    (if stl (setvar 'textstyle stl))
    (vla-endundomark doc)
    (princ))
  
  ; ----------------------------------------------------------------------------------------------------------------------
  
  (setq doc (vla-get-activedocument (vlax-get-acad-object))
	msp (vla-get-modelspace doc)
	stl (getvar 'textstyle))
  (vla-startundomark doc)
  
  (or (tblsearch "STYLE" "ISOCPEUR") 
      (command "_.style" "ISOCPEUR" "ISOCPEUR" "500" "" "" "" ""))
  (or (tblsearch "LAYER" "_Areas")
      (command "_.-layer" "_n" "_Areas" ""))
  
  (if (setq s (ssget "_A" (list '(0 . "HATCH") (cons 410 (getvar 'ctab)))))
    (repeat (setq i (sslength s))
      (setq e (ssname s (setq i (1- i)))
	    o (vlax-ename->vla-object e))
      (if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'll 'ur))))
	(progn
	  (setq p (vlax-3d-point (mapcar '/ (apply 'mapcar (cons '+ (mapcar 'vlax-safearray->list (list ll ur)))) '(2 2)))
		m (vla-addMText msp p 0 (strcat "%<\\AcObjProp Object(%<\\_ObjId "
						(itoa (vla-get-objectid o))
						">%).Area \\f \"%lu2%pr1%ps[, m\\\\U+00B2]%ct8[1.0E-006]\">%")))
	  (vla-put-AttachmentPoint m acAttachmentPointMiddleCenter)
	  (vla-put-InsertionPoint m p)
	  (vla-put-Layer m "_Areas")
	  (vla-put-Color m 7)
	  (vla-put-StyleName m "ISOCPEUR")
	  ))))
  (*error* "end")
  )

ВeekeeCZ · ‎03-20-2021

@karpki wrote:

"_Areas"

is one of my working layer always presented in drawing

that's why I use "_s"

I did not see that you set the color as text's property, not layer's.

Anyway, it might happen that for some extraordinary reason the layer won't there, the program will crash without saying why, so you'll be wondering..... better make sure it's there or tell the user that it's required in the error message.

(or (tblsearch "layer" "_Areas")

(prompt "Error: No layer _Areas in the drawing."))

ВeekeeCZ · ‎03-20-2021

@braudpat wrote:

Hello @ВeekeeCZ

I like this :
\\\\U+00B2
The Health, Bye, Patrice

Thanks, Patrice.

Here's the paradox - personally, I would never use this particular sign of index number in my drawings. Always use a regular number m2. It's just easier to do and still understandable enough. But it's a small exception from typography rules that I really do try to follow otherwise 🙂

But agree that it's a nice trick for the Unicode chars in generel.

PS. This one was added by @karpki himself 🙂

Community

Area Field LISP by Lee Mac to mod

Area Field LISP by Lee Mac to mod

Area Field LISP by Lee Mac to mod