Jump to content

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


aridzv

Recommended Posts

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.lspArea_To_Text_Boundery_M2A.lsp

Edited by aridzv
Link to comment
Share on other sites

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 by Emmanuel Delay
  • Like 1
  • Thanks 1
Link to comment
Share on other sites

@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.

 

  • Like 1
Link to comment
Share on other sites

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

Capture1.JPG

Edited by aridzv
  • Agree 1
Link to comment
Share on other sites

2 hours ago, mhupp said:

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 by aridzv
Link to comment
Share on other sites

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

 

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

  • 7 months later...
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?

Link to comment
Share on other sites

@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. 

Link to comment
Share on other sites

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

 

Link to comment
Share on other sites

  • 7 months later...

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

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

 

Video_2024-04-10_112822.gif.fb54fc8be9ad70d5fbffd0cc7f911e4c.gif

 

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

 

 

Link to comment
Share on other sites

  • 1 month later...
On 4/9/2024 at 9:31 PM, XDSoft said:

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

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

 

Video_2024-04-10_112822.gif.fb54fc8be9ad70d5fbffd0cc7f911e4c.gif

 

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

 

 

 

PLEASE,  CAN YOU MODIFY TO FIX LISP, THIS SHARE THIS MASSAGE: error: no function definition: XDRX-STRING-MULTILANGUAGE

Link to comment
Share on other sites

  • 1 month later...

 

On 1/10/2023 at 9: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, may I know how to make the area divide by 1e^-6 ? Also may I know how to turn the text align to the UCS's x-axis ? 

Link to comment
Share on other sites

See if this helps. 

In function WAMP

 

(setq area
    (/
        (vla-get-area (vlax-ename->vla-object pline)
        0.000001
    )
)

 

Link to comment
Share on other sites

This may be useful a single line finds the geometric centre of a pline. Thnaks to Kent Cooper for hint about Gcen

 

(setq pt (osnap (vlax-curve-getStartPoint obj) "gcen"))

 

Edited by BIGAL
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...