lisp to select multiple polygons and assign area text to them (already have lisp that do it for one polygon)

January 10, 2023

Hi.

I hvave a lisp (see attached Area_To_Text_Polygon_M2C).

this lisp do:

1. promt the user to select a single polygon.

2. prompt the user to select text insertion point.

what I'm lookig to do is:

1. promt the user to select multiple polygons.

2. in a loop:

a. calculate each polygon area.

b. insert the area text in the geometric center of each polygon

is something like that possible?

aridzv

*EDIT:

I have other lisp that do the same,only using picked boundery (pick a point inside a polygon) - maybe it will be easier to use that one and use the pick point of every closed boundery as the text inset point?

see attached Area_To_Text_Boundery_M2A.lsp.

Area_To_Text_Polygon_M2C.lsp Area_To_Text_Boundery_M2A.lsp

Edited January 10, 2023 by aridzv

January 10, 2023

I started from scratch.

Is this how you want is?

Bottom function: adapt the text height to your likings . Now: (setq hgt 2.5)

;;1. promt the user to select multiple polygons.
;;2. in a loop:
;;     a. calculate each polygon area.
;;     b. insert the area text in the geometric center of each polygon


(vl-load-com)

;; Multiple assoc.  Returns a list of all requested (assoc) with set key
; use like this (massoc 10 YourListOfData)
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    )
  )
  (reverse nlist)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawText (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; main function
(defun wamp (pline hgt / area pt str vert_pts x y p)
	
	(setq area (vla-get-area
		(vlax-ename->vla-object pline)
	))
	
	;; get the vertex positions. 
	(setq vert_pts (massoc 10 (entget pline)))
	(setq x 0.0)
	(setq y 0.0)
		;;  Then calculate the average.  Sum of x and y values divided by the number of vertices
	(foreach p vert_pts
		(setq x (+ x (nth 0 p)))	
		(setq y (+ y (nth 1 p)))	
	)
	(setq pt (list
		(/ x (length vert_pts))
		(/ y (length vert_pts))
	))
		;; make a string out of the area float.  Here would be the place to add a prefix  or postfix.  Example: 
		;; (setq str (strcat "area: " (rtos area 2 3) ))
				
	(setq str (rtos area 2 3))  ;; that 3 means 3 decimals.  Feel free to change this
	
	(drawText pt hgt str)
	
	(princ )	
	
)

;; WAMP for Write Area in the Middle of Polyline
(defun c:wamp ( / pline ss i hgt)
	
	;; User setting.  Set to your liking
	(setq hgt 2.5)

	;; user selects polylines
	(princ "\nSelect polylines: ")
	(setq ss (ssget (list (cons 0 "*POLYLINE"))))
	
	;; loop of the elements
	(setq i 0)
	(repeat (sslength ss)
		(setq pline (ssname ss i))
		(wamp pline hgt)
		(setq i (+ i 1))
	)
)

Edited January 10, 2023 by Emmanuel Delay

January 10, 2023

@Emmanuel Delay

AMAIZING- THANKS!!

how complicate is to do the same for selection by internal point like the second lisp I have posted (Area_To_Text_Boundery_M2A.lsp)?

I looked for an exampels of creating a selection set by choosing internal points like in the command for a single object:

(command "-Boundary" a "")

but could'nt find any.

many thanks,

aridzv.

January 10, 2023

http://www.lee-mac.com/arealabel.html

January 10, 2023

@Emmanuel Delay

I have one more question -

Iv'e tried to change the rext justification to middle center like this:

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawText (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 73 2)
                 (cons 72 1)
                 (cons 1  str))))

but when I do that all the text items are put to 0,0,0 (ignore cons 10 pt).

is there a way to fix it?

*EDIT:

cons 11 is the solution...

when using cons 72 & cons 73 must assign the insertion point to cons 11 as well..

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawText (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 11 pt)
                 (cons 10  pt)
                 (cons 40 (getvar "TEXTSIZE"))
                 (cons 7 (getvar "TEXTSTYLE"))
                 (cons 73 2)
                 (cons 72 1)
                 (cons 1  str))))

I've also attched a screenshot from the DXF Reference guide (Capture1.JPG)

Edited January 10, 2023 by aridzv

January 10, 2023

2 hours ago, mhupp said:

http://www.lee-mac.com/arealabel.html

well,it dosen't what I need...

what I'm looking for help with is a way to click inside a closed polylines one after the other,

and when I'm done to let the lisp to put the area text inside each one of them.

is somthing like that is possible?

Edited January 10, 2023 by aridzv

January 10, 2023

I have this with field

It work's with entities selection or boundarie

(vl-load-com)
(defun c:surf_curve-closed ( / AcDoc Space loop js pt_in new_pl area_obj nw_obj ename ent_text dxf_ent key)
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
    loop T
  )
  (princ "\nSelect a closed object or <Enter/Right-click> for a point in interior of area")
  (while loop
    (setq
      js
      (ssget "_+.:E:S"
        '(
          (-4 . "<OR")
            (-4 . "<AND")
              (0 . "*POLYLINE")
              (-4 . "<AND")
                (-4 . "<NOT") (-4 . "&") (70 . 120) (-4 . "NOT>")
                (-4 . "&") (70 . 1)
              (-4 . "AND>")
            (-4 . "AND>")
            (0 . "CIRCLE")
            (-4 . "<AND")
              (0 . "SPLINE")
              (-4 . "&") (70 . 1)
            (-4 . "AND>")
            (-4 . "<AND")
              (0 . "ELLIPSE")
              (41 . 0.0)
              (42 . 6.283185307179586)
            (-4 . "AND>")
          (-4 . "OR>")
        )
      )
      area_obj nil
    )
    (cond
      ((null js)
        (setq
          pt_in (getpoint "\nGive interior point or <Enter/Right-click> for quit?: ")
          new_pl (bpoly pt_in nil '(0 0 1))
        )
        (if (eq (type new_pl) 'ENAME)
          (setq area_obj (vlax-get-property (setq ename (vlax-ename->vla-object new_pl)) "Area"))
          (setq loop nil)
        )
      )
      (T
        (setq area_obj (vlax-get-property (setq ename (vlax-ename->vla-object (ssname js 0))) "Area"))
      )
    )
    (cond
      (area_obj
        (if (zerop (getvar "USERR1")) (setvar "USERR1" (/ (getvar "VIEWSIZE") 75.0)))
        (setq nw_obj
          (vla-addMtext Space
            (vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
            0.0
            (strcat
              "{\\fArial|b0|i0|c0|p34;"
              "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
              (itoa (vla-get-ObjectID ename))
              ">%).Area \\f \"%lu2%pr3\">%"
            )
          )
        )
        (mapcar
          '(lambda (pr val)
            (vlax-put nw_obj pr val)
          )
          (list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'BackgroundFill 'Color)
          (list 1 (getvar "USERR1") 5 (getvar "TEXTSTYLE") (getvar "CLAYER") 0.0 -1 256)
        )
        (setq
          ent_text (entlast)
          dxf_ent (entget ent_text)
          dxf_ent (subst (cons 90 1) (assoc 90 dxf_ent) dxf_ent)
          dxf_ent (subst (cons 63 255) (assoc 63 dxf_ent) dxf_ent)
        )
        (entmod dxf_ent)
        (while (and (setq key (grread T 4 0)) (/= (car key) 3))
          (cond
            ((eq (car key) 5)
              (setq dxf_ent (subst (cons 10 (trans (cadr key) 1 0)) (assoc 10 dxf_ent) dxf_ent))
              (entmod dxf_ent)
            )
          )
        )
        (vlax-put
          (vlax-ename->vla-object (entlast))
          'TextString
          (strcat
            "{\\fArial|b0|i0|c0|p34;"
            "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
            (itoa (vla-get-ObjectID ename))
            ">%).Area \\f \"%lu2%pr3\">%"
          )
        )
      )
      (T (setq loop nil))
    )
    (princ "\nSelect a closed object or <Enter/Right-click> for a point in interior of area")
  )
  (prin1)
)

January 11, 2023

23 hours ago, Tsuky said:

I have this with field

It work's with entities selection or boundarie

(vl-load-com)
(defun c:surf_curve-closed ( / AcDoc Space loop js pt_in new_pl area_obj nw_obj ename ent_text dxf_ent key)
  (setq
    AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
    Space
    (if (= 1 (getvar "CVPORT"))
      (vla-get-PaperSpace AcDoc)
      (vla-get-ModelSpace AcDoc)
    )
    loop T
  )
  (princ "\nSelect a closed object or <Enter/Right-click> for a point in interior of area")
  (while loop
    (setq
      js
      (ssget "_+.:E:S"
        '(
          (-4 . "<OR")
            (-4 . "<AND")
              (0 . "*POLYLINE")
              (-4 . "<AND")
                (-4 . "<NOT") (-4 . "&") (70 . 120) (-4 . "NOT>")
                (-4 . "&") (70 . 1)
              (-4 . "AND>")
            (-4 . "AND>")
            (0 . "CIRCLE")
            (-4 . "<AND")
              (0 . "SPLINE")
              (-4 . "&") (70 . 1)
            (-4 . "AND>")
            (-4 . "<AND")
              (0 . "ELLIPSE")
              (41 . 0.0)
              (42 . 6.283185307179586)
            (-4 . "AND>")
          (-4 . "OR>")
        )
      )
      area_obj nil
    )
    (cond
      ((null js)
        (setq
          pt_in (getpoint "\nGive interior point or <Enter/Right-click> for quit?: ")
          new_pl (bpoly pt_in nil '(0 0 1))
        )
        (if (eq (type new_pl) 'ENAME)
          (setq area_obj (vlax-get-property (setq ename (vlax-ename->vla-object new_pl)) "Area"))
          (setq loop nil)
        )
      )
      (T
        (setq area_obj (vlax-get-property (setq ename (vlax-ename->vla-object (ssname js 0))) "Area"))
      )
    )
    (cond
      (area_obj
        (if (zerop (getvar "USERR1")) (setvar "USERR1" (/ (getvar "VIEWSIZE") 75.0)))
        (setq nw_obj
          (vla-addMtext Space
            (vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
            0.0
            (strcat
              "{\\fArial|b0|i0|c0|p34;"
              "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
              (itoa (vla-get-ObjectID ename))
              ">%).Area \\f \"%lu2%pr3\">%"
            )
          )
        )
        (mapcar
          '(lambda (pr val)
            (vlax-put nw_obj pr val)
          )
          (list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'BackgroundFill 'Color)
          (list 1 (getvar "USERR1") 5 (getvar "TEXTSTYLE") (getvar "CLAYER") 0.0 -1 256)
        )
        (setq
          ent_text (entlast)
          dxf_ent (entget ent_text)
          dxf_ent (subst (cons 90 1) (assoc 90 dxf_ent) dxf_ent)
          dxf_ent (subst (cons 63 255) (assoc 63 dxf_ent) dxf_ent)
        )
        (entmod dxf_ent)
        (while (and (setq key (grread T 4 0)) (/= (car key) 3))
          (cond
            ((eq (car key) 5)
              (setq dxf_ent (subst (cons 10 (trans (cadr key) 1 0)) (assoc 10 dxf_ent) dxf_ent))
              (entmod dxf_ent)
            )
          )
        )
        (vlax-put
          (vlax-ename->vla-object (entlast))
          'TextString
          (strcat
            "{\\fArial|b0|i0|c0|p34;"
            "%<\\AcObjProp.16.2 Object(%<\\_ObjId "
            (itoa (vla-get-ObjectID ename))
            ">%).Area \\f \"%lu2%pr3\">%"
          )
        )
      )
      (T (setq loop nil))
    )
    (princ "\nSelect a closed object or <Enter/Right-click> for a point in interior of area")
  )
  (prin1)
)

thanks for the reply!!

I tried to use your program, but I couldn't quite understand how it works....
But anyway, thanks for the response!!

aridzv.

August 20, 2023

On 1/10/2023 at 4:39 PM, Emmanuel Delay said:

I started from scratch.

Is this how you want is?

Bottom function: adapt the text height to your likings . Now: (setq hgt 2.5)

;;1. promt the user to select multiple polygons.
;;2. in a loop:
;;     a. calculate each polygon area.
;;     b. insert the area text in the geometric center of each polygon


(vl-load-com)

;; Multiple assoc.  Returns a list of all requested (assoc) with set key
; use like this (massoc 10 YourListOfData)
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
    )
  )
  (reverse nlist)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; https://www.cadtutor.net/forum/topic/18257-entmake-functions/
(defun drawText (pt hgt str)
 (entmakex (list (cons 0 "TEXT")
                 (cons 10  pt)
                 (cons 40 hgt)
                 (cons 1  str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; main function
(defun wamp (pline hgt / area pt str vert_pts x y p)
	
	(setq area (vla-get-area
		(vlax-ename->vla-object pline)
	))
	
	;; get the vertex positions. 
	(setq vert_pts (massoc 10 (entget pline)))
	(setq x 0.0)
	(setq y 0.0)
		;;  Then calculate the average.  Sum of x and y values divided by the number of vertices
	(foreach p vert_pts
		(setq x (+ x (nth 0 p)))	
		(setq y (+ y (nth 1 p)))	
	)
	(setq pt (list
		(/ x (length vert_pts))
		(/ y (length vert_pts))
	))
		;; make a string out of the area float.  Here would be the place to add a prefix  or postfix.  Example: 
		;; (setq str (strcat "area: " (rtos area 2 3) ))
				
	(setq str (rtos area 2 3))  ;; that 3 means 3 decimals.  Feel free to change this
	
	(drawText pt hgt str)
	
	(princ )	
	
)

;; WAMP for Write Area in the Middle of Polyline
(defun c:wamp ( / pline ss i hgt)
	
	;; User setting.  Set to your liking
	(setq hgt 2.5)

	;; user selects polylines
	(princ "\nSelect polylines: ")
	(setq ss (ssget (list (cons 0 "*POLYLINE"))))
	
	;; loop of the elements
	(setq i 0)
	(repeat (sslength ss)
		(setq pline (ssname ss i))
		(wamp pline hgt)
		(setq i (+ i 1))
	)
)

Hi Emmanuel Delay, is it possible to put the text in the layer of the closed polygons? Also is this possible to reduce the area, if there is a small closed polygon within the bigger polygon can the area of the bigger polygon be reduced?

August 20, 2023

@Cadworker

look for leeMac's area lisps you may have options for this. Or else after getting the area for all the closed topology you can try manually doing the subtractions. or look for some ways to do in Arcmap.

August 21, 2023

21 hours ago, CADWORKER said:

Hi Emmanuel Delay, is it possible to put the text in the layer of the closed polygons? Also is this possible to reduce the area, if there is a small closed polygon within the bigger polygon can the area of the bigger polygon be reduced?

Sure. Replace this function. I didn't touch the rest


;; WAMP for Write Area in the Middle of Polyline
(defun c:wamp ( / pline ss i hgt clay lay)
	;; current layer
	(setq clay (getvar "CLAYER"))
	;; User setting.  Set to your liking
	(setq hgt 2.5)

	;; user selects polylines
	(princ "\nSelect polylines: ")
	(setq ss (ssget (list (cons 0 "*POLYLINE"))))
	
	;; loop of the elements
	(setq i 0)
	(repeat (sslength ss)
		(setq pline (ssname ss i))
		;; set layer of polyline to current
		(setvar "CLAYER" 
			(setq lay (cdr (assoc 8 (entget pline))))
		)
		(wamp pline hgt)
		(setq i (+ i 1))
	)
	(setvar "CLAYER" clay)
)

April 10

[XDrX-PlugIn(134)] Land plot (Polygon) analysis statistics (theswamp.org)

https://www.theswamp.org/index.php?topic=59435.0

(defun c:xdtb_pl-analyze (/ #area #centroid #length #numverts #xd-var-global-text-height end-row height i lst minl mtxt n
	       pt pts ss start-row str tbl temp tlst tlst1 verts w x
	    )
  (xd::doc:getdouble (xdrx-string-multilanguage "\n文字高度：" "\nText Height:") "#xd-var-global-text-height"
		     (setq height (xd::doc:getpickboxheight))
  )
  (if (setq ss (xdrx-ssget (xdrx-string-multilanguage "\n选择封闭的多段线<退出>:"
						      "\nSelect Closed Polyline<Exit>:"
			   ) '((0 . "*POLYLINE") (-4 . "&=")
			    (70 . 1)
			   )
	       )
      )
    (progn
      (xdrx-begin)
      (setq lst (xdrx-entity-getproperty ss "boundingbox"))
      (setq lst (mapcar
		  '(lambda (x)
		     (setq temp (car x))
		     (min
		       (distance (car temp) (cadr temp))
		       (distance (cadr temp) (caddr temp))
		     )
		   )
		  lst
		)
      )
      (setq minl (apply
		   'min
		   lst
		 )
      )
      (xdrx-document-setprec (/ minl 2.0))
      (setq lst (xd::pickset:tablesort ss 0 3 '< '>)
	    i 0
	    verts nil
	    tlst nil
      )
      (mapcar
	'(lambda (x)
	   (xdrx-getpropertyvalue x "centroid" "area" "length" "numverts")
	   (setq verts (cons (list (setq i (1+ i))
				   #numverts
			     ) verts
		       )
	   )
	   (setq mtxt (xdrx-mtext-make #centroid (setq str (xdrx-string-formatex "%d\nL=%.1f\nS=%.2f" i
										 #length #area
							   )
						 )
				       1.0 #xd-var-global-text-height
		      )
	   )
	   (xdrx-setpropertyvalue mtxt "attachment" 5)
	   (setq pts (xdrx-getpropertyvalue x "vertices")
		 pts (xd::pnts:open pts)
		 #numverts (length pts))
	   (foreach n pts
	     (setq tlst (cons (list i #numverts (rtos #length 2 4) (rtos #area 2 4) (rtos (car n) 2 4)
				    (rtos (cadr n) 2 4) (rtos (caddr n) 2 4)

			      ) tlst
			)
	     )
	   )
	 )
	(xd::list:flat lst)
      )
      (setq tlst (reverse tlst))
      (setq tlst (cons (list (xdrx-string-multilanguage "地块统计表" "Plot Statistics Table") nil nil nil nil
			     nil nil
		       ) (cons (list (xdrx-string-multilanguage "编号" "P&N")
				     (xdrx-string-multilanguage "顶点数" "N&V")
				     (xdrx-string-multilanguage "长度" "Length")
				     (xdrx-string-multilanguage "面积" "Area")
				     (xdrx-string-multilanguage "X坐标" "X coordinate")
				     (xdrx-string-multilanguage "Y坐标" "Y coordinate")
				     (xdrx-string-multilanguage "Z坐标" "Z coordinate")
			       ) tlst
			 )
		 )
      )
      (if (setq pt (getpoint (xdrx-string-multilanguage "\n表格插入点<退出>:" "\nTable Insert Point<Exit>:")))
	(progn
	  (setq w (* (xd::var:getratio) #xd-var-global-text-height))
	  (xd::table:makefromlist tlst pt w (/ w 2.0))
	  (setq tbl (entlast))
	  (setq verts (reverse verts)
		start-row 2
	  )
	  (foreach n verts
	    (setq end-row (1- (+ start-row (last n))))
	    (xdrx_table_MergeCells tbl start-row end-row 0 0)
	    (xdrx_table_MergeCells tbl start-row end-row 1 1)
	    (xdrx_table_MergeCells tbl start-row end-row 2 2)
	    (xdrx_table_MergeCells tbl start-row end-row 3 3)
	    (setq start-row (1+ end-row))
	  )
	)
      )
      (xdrx-end)
    )
  )
  (princ)
)

lisp to select multiple polygons and assign area text to them (already have lisp that do it for one polygon)

Recommended Posts

aridzv

Link to comment

Share on other sites

Emmanuel Delay

Link to comment

Share on other sites

aridzv

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

aridzv

Link to comment

Share on other sites

aridzv

Link to comment

Share on other sites

Tsuky

Link to comment

Share on other sites

aridzv

Link to comment

Share on other sites

CADWORKER

Link to comment

Share on other sites

symoin

Link to comment

Share on other sites

Emmanuel Delay

Link to comment

Share on other sites

XDSoft

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity