Trapezoid area lisp

#1
Hi, I am using this lisp for analytic calculation areas in architectonic drawings. Is it possible to update the code to support trapezoid area ?

E = 1/2 x (a+b) x h

Code: Select all

(defun c:areacal ( / js nb ent dxf_ent ptlst surf n AcDoc Space old_textsize count app_txt cum_area pt_ins val_txt lst_bis l_4d max_d pos pt1 pt2 pt3 d1 d2 nw_obj ent_text key)
       (command "_layer" "_m" "AREA CALC" "_c" "7" "" "")
       (command "_.-style" "AREA CALC" "arial.ttf" 2.5 "1" "0" "n" "n" "n")
	(while (null (setq js (ssget '((0 . "LWPOLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . ">") (90 . 2) (-4 . "<") (90 . 5) (-4 . "AND>"))))))
	(repeat (setq nb (sslength js))
		(setq
			ent (ssname js (setq nb (1- nb)))
			dxf_ent (entget ent)
			ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
			n (length ptlst)
		)
		(if (eq n 4)
			(if (not (and (equal (distance (car ptlst) (cadr ptlst)) (distance (caddr ptlst) (cadddr ptlst)) 1E-08)))
				(ssdel ent js)
			)
		)
	)
	(cond
		((and js (> (sslength js) 0))
			(sssetfirst nil js)
			(initget "Yes No")
			(cond
				((not (eq (getkword "\n Insert calculations [Yes/No]? <Yes>: ") "No"))
					(sssetfirst nil nil)
					(setq
						AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
						Space
						(if (= 1 (getvar "CVPORT"))
							(vla-get-PaperSpace AcDoc)
							(vla-get-ModelSpace AcDoc)
						)
						old_textsize (getvar "TEXTSIZE")
						count 0
						app_txt ""
						cum_area 0.0
					)
					(setvar "TEXTSIZE" 2.5)
					(repeat (setq nb (sslength js))
						(setq
							ent (ssname js (setq nb (1- nb)))
							dxf_ent (entget ent)
							ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
							n (length ptlst)
							pt_ins (list (/ (apply '+ (mapcar 'car ptlst)) n) (/ (apply '+ (mapcar 'cadr ptlst)) n))
							val_txt
							(if (eq n 3)
								(progn
									(setq
										lst_bis (append (cdr ptlst) (list (car ptlst)))
										l_4d (mapcar 'distance ptlst lst_bis)
										max_d (apply 'max l_4d)
										pos (vl-position max_d l_4d)
										pt1 (nth pos ptlst)
										pt2 (nth pos lst_bis)
										pt3 (car (vl-remove pt2 (vl-remove pt1 ptlst)))
										d1
										(distance
											pt3
											(inters
												pt1
												pt2
												pt3
												(polar pt3 (+ (angle pt1 pt2) (* pi 0.5)) (distance pt1 pt2))
												nil
											)
										)
										surf (* (atof(rtos max_d 2 2)) (atof (rtos d1 2 2)) 0.5)
										cum_area (atof (rtos (+ surf cum_area) 2 2))
									)
									(strcat
										"Ε" (itoa (setq count (1+ count))) " = "
										"1/2 x "
										(rtos max_d 2 2)
										" x "
										(rtos d1 2 2)
										" = "
										(rtos surf 2 2) " sq.m\\P"
									)
								)
								(progn
									(setq
										d1 (atof (rtos (distance (car ptlst) (cadr ptlst)) 2 2))
										d2 (atof (rtos (distance (cadr ptlst) (caddr ptlst)) 2 2))
										surf (atof (rtos (* d1 d2) 2 2))
										cum_area (atof (rtos (+ surf cum_area) 2 2))
									)
									(strcat
										"Ε" (itoa (setq count (1+ count))) " = "
										(rtos d1 2 2)
										" x "
										(rtos d2 2 2)
										" = "
										(rtos surf 2 2)
										" sq.m\\P"
									)
								)
							)
							app_txt (strcat app_txt val_txt)
						)
						(entmake
							(list
								'(0 . "TEXT")
								'(100 . "AcDbEntity")
								(cons 8 (getvar "CLAYER"))
								'(100 . "AcDbText")
								(cons 10 pt_ins)
								(cons 40 (getvar "TEXTSIZE"))
								(cons 1 (strcat "E" (itoa count)))
								(cons 50 (angle '(0 0 0) (getvar "UCSXDIR")))
								'(41 . 1.0)
								'(51 . 0.0)
								(cons 7 (getvar "TEXTSTYLE"))
								'(71 . 0)
								'(72 . 1)
								(cons 11 pt_ins)
								(assoc 210 dxf_ent)
								'(100 . "AcDbText")
								'(73 . 2)
							)
						)
					)
					(setq nw_obj
						(vla-addMtext Space
							(vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
							0.0
							(strcat app_txt "Εολ = " (rtos cum_area 2 2) " sq.m")
						)
					)
					(mapcar
						'(lambda (pr val)
							(vlax-put nw_obj pr val)
						)
						(list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation 'BackgroundFill 'Color)
						;(list 1 (getvar "TEXTSIZE") 5 (getvar "TEXTSTYLE") (getvar "CLAYER") 0.0 -1 250)
						(list 1 (getvar "TEXTSIZE") 5 (getvar "TEXTSTYLE") (getvar "CLAYER") 0.0 0 0)
					)
					(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)
							)
						)
					)
					(setvar "TEXTSIZE" old_textsize)
				)
				(T (sssetfirst nil nil) (princ "\nFunction canceled"))
			)
		)
		(T (princ "\nSelected items are invalid"))
	)
	(princ)
;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
(*error* "")
)

Re: Trapezoid area lisp

#4
Hi SPirou4D. This code select close polylines rectangles and triangrles and insert calculate the area, and insert text with analytic calculation of this areas. I want to add in this code to calculate the area of trapezoid, with the type E = 1/2 x (a+b) x h . Can any one help?

Thanks

Re: Trapezoid area lisp

#5
The lisp above works on the Rectangle only.
Please refer to simple lisp to get the area property of the LwPolyline:

Code: Select all

(defun c:areacal (/ area dxf_ent ent js n nb ptlst pt_ins)
  (if (setq js (ssget '((0 . "LWPOLYLINE")
			(-4 . "<AND")
			(-4 . "&")
			(70 . 1)
			(-4 . ">")
			(90 . 2)
			(-4 . "<")
			(90 . 5)
			(-4 . "AND>")
		       )
	       )
      )
    (progn
      (repeat (setq nb (sslength js))
	(setq ent     (ssname js (setq nb (1- nb)))
	      dxf_ent (entget ent)
	      ptlst   (mapcar 'cdr
			      (vl-remove-if-not
				'(lambda (x) (= (car x) 10))
				dxf_ent
			      )
		      )
	      n	      (length ptlst)
	      pt_ins  (list (/ (apply '+ (mapcar 'car ptlst)) n)
			    (/ (apply '+ (mapcar 'cadr ptlst)) n)
		      )
	      area    (vla-get-Area (vlax-ename->vla-Object ent))
	)
	(entmake
	  (list
	    '(0 . "TEXT")
	    (cons 10 pt_ins)
	    (cons 40 (getvar "TEXTSIZE"))
	    (cons 1 (strcat "Area= " (rtos area)))
	    (cons 72 4)
	    (cons 11 pt_ins)
	  )
	)
      )
    )
  )
  (princ)
)

Re: Trapezoid area lisp

#7
select rectangles / triangles / close polylines
+
calculate their areas
+
insert text with analytic calculation of this areas.
++++++++++++++++++++++++++++++++++++++++++++
= add in this code to calculate the area of trapezoid,
function [1/2 x (a+b) x h ]
++++++++++++++++++++++++++++++++++++++++++++

What is a ?
What is b ?
What is h ?

This lisp use the unique width and height but not a second width b for rectangles or closed polylines.
so you must modify this code for number of points <= 4 points and h egual height :
1 with a first width egual to 0 and a second width b for triangles.
2 with a second width b egual to first width a when rectangles.
3 idem with closed polylines.
4 with a and b and h for trapezoidal.
HERE=>

Code: Select all

(repeat (setq nb (sslength js))
		(setq
			ent (ssname js (setq nb (1- nb)))
			dxf_ent (entget ent)
			ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
			n (length ptlst)
		)
		(if (eq n 4)
			(if (not (and (equal (distance (car ptlst) (cadr ptlst)) (distance (caddr ptlst) (cadddr ptlst)) 1E-08)))
				(ssdel ent js)
			)
		)
	)
Good luck!
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#8
The area and length of any Plines shows in the Properties window and under List, was there some other reason you needed to code for?
Sorry if I don't understand the full meaning of your question.
Hope this helps.
-=(RH)=-
ProM wrote:
Sun Dec 11, 2022 6:59 am
Hi, I am using this lisp for analytic calculation areas in architectonic drawings. Is it possible to update the code to support trapezoid area ?

E = 1/2 x (a+b) x h

Code: Select all

(defun c:areacal ( / js nb ent dxf_ent ptlst surf n AcDoc Space old_textsize count app_txt cum_area pt_ins val_txt lst_bis l_4d max_d pos pt1 pt2 pt3 d1 d2 nw_obj ent_text key)
       (command "_layer" "_m" "AREA CALC" "_c" "7" "" "")
...
...
33+ years using Autocad, wanting to fully learn iCad and share my knowledge of applicable crossover info from Acad.
-=(RLH)=-

Re: Trapezoid area lisp

#9
This code is weird, you must select the item your-self?
I try it in French UI but I can't understand how it work.....I will try in US UI.
image_2022-12-13_113245773.png
image_2022-12-13_113245773.png (35.97 KiB) Viewed 4269 times
Explanations:
1 layer creation
2 go to the new layer to write
3 choose the style of the text
4 ask if you write the text backwards
5 ask if you write the text upside-down
6 select the items
7 ask if you write the calculations
8 "error: application is locked and cannot be unloaded." ???

I mean your code is for AutoCAD but not for IntelliCAD !
rhgrafix was right, area is calculated automatically for all items or you can use the _AREA command too....
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#10
If you answer to this list of parameters, we can help you. Coding is not a riddle :
; js = ?
; nb =
; ent =
; dxf_ent =
; ptlst =
; surf =
; n =
; AcDoc =
; Space =
; old_textsize =
; count =
; app_txt =
; cum_area =
; pt_ins =
; val_txt =
; lst_bis =
; lst_bis =
; l_4d =
; max_d =
; pos =
; pt1 =
; pt2 =
; pt3 =
; d1 =
; d2 =
; nw_obj =
; ent_text =
; key =
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#11
I found the solution to your problem: You must remove this code in 45-49 lines:

Code: Select all

; Delete Trapezoids in selection
(if (eq n 4)
	(if (not (and (equal (distance (car ptlst) (cadr ptlst)) (distance (caddr ptlst) (cadddr ptlst)) 1E-08)))
	(ssdel ent js)
	)
)
.......; to selection trapezoids too in area calculation of this script.
Last edited by SPirou4D on Thu Dec 15, 2022 9:48 am, edited 7 times in total.
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#12
ProM wrote:
Sun Dec 11, 2022 4:27 pm
Hi SPirou4D. This code select close polylines rectangles and triangrles and insert calculate the area, and insert text with analytic calculation of this areas. I want to add in this code to calculate the area of trapezoid, with the type E = 1/2 x (a+b) x h . Can any one help?

Thanks
Do you want something like this? (E3 figure)
area_polygon.png
area_polygon.png (48.77 KiB) Viewed 4243 times

Re: Trapezoid area lisp

#13
Here is a real trapezoid =
image_2022-12-17_104120234.png
image_2022-12-17_104120234.png (31.5 KiB) Viewed 4176 times
For me, Trapezoids area is triangle ABC area + triangle CDA area
E1 = 1/2 x (h1 + h2) x largest diagonal

Example here :
E1 = 0.5 x (35.78 x 47.69) = 853.47

So you look for the largest diagonal
and in the code, line 46-79 there are triangle calculation, you can re-use it two times.....
Good luck !
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#14
Here is my new script for your demand :

Code: Select all

(vl-load-com)
(defun c:areacal (/ js nb ent dxf_ent ptlst surf n AcDoc Space old_textsize count app_txt cum_area pt_ins val_txt lst_bis l_4d max_d pos pt1 pt2 pt3 d1 d2 diag1 diag2 diag max_diag pt4 surf1 surf2  nw_obj ent_text key)
	(command "_layer" "_m" "AREA CALC" "_c" "7" "" "")
	(command "_.-style" "AREA CALC" "arial.ttf" 2.5 "1" "0" "No" "No")
	(while (null (setq js (ssget '((0 . "LWPOLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . ">") (90 . 2) (-4 . "<") (90 . 5) (-4 . "AND>"))))))
	(repeat (setq nb (sslength js))
		(setq
			ent (ssname js (setq nb (1- nb)))
			dxf_ent (entget ent)
			ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
			n (length ptlst)
		)
	)
	(cond
		((and js (> (sslength js) 0))
			(sssetfirst nil js)
			(initget "Yes No")
			(cond
				((not (eq (getkword "\n Insert calculations [Yes/No]? <Yes>: ") "No"))
					(sssetfirst nil nil)
					(setq
						AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))
						Space
						(if (= 1 (getvar "CVPORT"))
							(vla-get-PaperSpace AcDoc)
							(vla-get-ModelSpace AcDoc)
						)
						old_textsize (getvar "TEXTSIZE")
						count 0
						app_txt ""
						cum_area 0.0
					)
					(setvar "TEXTSIZE" 2.5)
					(repeat (setq nb (sslength js))
						(setq
							ent (ssname js (setq nb (1- nb)))
							dxf_ent (entget ent)
							ptlst (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) dxf_ent))
							n (length ptlst)
							pt_ins (list (/ (apply '+ (mapcar 'car ptlst)) n) (/ (apply '+ (mapcar 'cadr ptlst)) n))
							val_txt
							(if (eq n 3)
								; triangles
								(progn
									(setq
										lst_bis (append (cdr ptlst) (list (car ptlst)))
										l_4d (mapcar 'distance ptlst lst_bis)
										max_d (apply 'max l_4d)
										pos (vl-position max_d l_4d)
										pt1 (nth pos ptlst)
										pt2 (nth pos lst_bis)
										pt3 (car (vl-remove pt2 (vl-remove pt1 ptlst)))
										d1
										(distance
											pt3
											(inters
												pt1
												pt2
												pt3
												(polar pt3 (+ (angle pt1 pt2) (* pi 0.5)) (distance pt1 pt2))
												nil
											)
										)
										surf (* (atof(rtos max_d 2 3)) (atof (rtos d1 2 3)) 0.5)
										cum_area (atof (rtos (+ surf cum_area) 2 3))
									)
									(strcat
										"E" (itoa (setq count (1+ count))) " = "
										"1/2 x "
										(rtos max_d 2 2)
										" x (ht "
										(rtos d1 2 2)
										") = "
										(rtos surf 2 2) " m2\\P"
									)
								)
								; equilateral
								(if (and
									(equal (distance (car ptlst) (cadr ptlst)) (distance (caddr ptlst) (cadddr ptlst)))
									(equal (distance (car ptlst) (caddr ptlst)) (distance (cadr ptlst) (cadddr ptlst))))
									(progn
										(setq
											d1 (atof (rtos (distance (car ptlst) (cadr ptlst)) 2 3))
											d2 (atof (rtos (distance (cadr ptlst) (caddr ptlst)) 2 3))
											surf (atof (rtos (* d1 d2) 2 3))
											cum_area (atof (rtos (+ surf cum_area) 2 3))
										)
										(strcat
											"E" (itoa (setq count (1+ count))) " = "
											(rtos d1 2 2)
											" x "
											(rtos d2 2 2)
											" = "
											(rtos surf 2 2)
											" m2\\P"
										)
									)
									; trapezoidals
									(progn
										(setq
											diag1 (distance (car ptlst) (caddr ptlst))
											diag2 (distance (cadr ptlst) (cadddr ptlst))
											diag (list diag1 diag2)
											max_diag (apply 'max diag)
											pt1 (if(> diag1 diag2) (car ptlst) (cadr ptlst))
											pt2 (if(> diag1 diag2) (caddr ptlst) (cadddr ptlst))
											pt3 (if(> diag1 diag2) (cadr ptlst) (caddr ptlst))
											pt4 (if(> diag1 diag2) (cadddr ptlst) (car ptlst))										
											d1  
											(distance
												pt3
												(inters
													pt1
													pt2
													pt3 
													(polar pt3 (+ (angle pt1 pt2) (* pi 0.5)) (distance pt1 pt2))
													nil
												)
											)
											d2  
											(distance
												pt4
												(inters
													pt1
													pt2
													pt4 
													(polar pt4 (+ (angle pt1 pt2) (* pi 0.5)) (distance pt1 pt2))
													nil
												)
											)
											ht 	(atof (rtos (+ d1 d2) 2 3))
											surf (* (atof(rtos max_diag 2 3)) (atof (rtos ht 2 3)) 0.5)
											cum_area (atof (rtos (+ surf cum_area) 2 3))
										)
										(strcat
											"E" (itoa (setq count (1+ count))) " = "
											"1/2 x "
											(rtos max_diag 2 2)
											" x (ht "
											(rtos ht 2 2)
											") = "
											(rtos surf 2 2) " m2\\P"
										)
									)							
								)									
							)
							app_txt (strcat app_txt val_txt)
						)
						(entmake
							(list
								'(0 . "TEXT")
								'(100 . "AcDbEntity")
								(cons 8 (getvar "CLAYER"))
								'(100 . "AcDbText")
								(cons 10 pt_ins)
								(cons 40 (getvar "TEXTSIZE"))
								(cons 1 (strcat "E" (itoa count)))
								(cons 50 (angle '(0 0 0) (getvar "UCSXDIR")))
								'(41 . 1.0)
								'(51 . 0.0)
								(cons 7 (getvar "TEXTSTYLE"))
								'(71 . 0)
								'(72 . 1)
								(cons 11 pt_ins)
								(assoc 210 dxf_ent)
								'(100 . "AcDbText")
								'(73 . 2)
							)
						)
					)
					(setq nw_obj
						(vla-addMtext Space
							(vlax-3d-point (trans (getvar "VIEWCTR") 1 0))
							0.0
							(strcat app_txt "TOTAL = " (rtos cum_area 2 2) " m2")
						)
					)
					;(setq entvla (vlax-ename->vla-object (car (entsel "\nChoix de l'entité\n"))))
					;(vlax-dump-object entvla)
					(mapcar
						'(lambda (pr val)
							(vlax-put nw_obj pr val)
						)
						(list 'AttachmentPoint 'color 'DrawingDirection 'Height 'Layer 'Linetype 'LinetypeScale 'Lineweight 'StyleName 'Rotation 'Visible)
						(list 1 18 1 (getvar "TEXTSIZE") (getvar "CLAYER") (getvar "LINETYPE") 1 (getvar "LINEWEIGHT") (getvar "TEXTSTYLE") 0.0 -1)
					)
					(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)
							)
						)
					)
					(setvar "TEXTSIZE" old_textsize)
				)
				(T (sssetfirst nil nil) (princ "\nFunction canceled because no calculation"))
			)
		)
		(T (princ "\nSelected items are invalid"))
	)
	(princ)
;return on the layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
(*error* "Modify your code !")
)
image_2022-12-23_192235420.png
image_2022-12-23_192235420.png (31.93 KiB) Viewed 4126 times
Last edited by SPirou4D on Sun Dec 25, 2022 12:19 pm, edited 8 times in total.
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture

Re: Trapezoid area lisp

#15
BUT I can't remove to this problem :

Code: Select all

error: too few arguments
nil
If someone can help me to correct this Please !

I think the error come from this code:

Code: Select all

(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)
					)
Last edited by SPirou4D on Sat Dec 24, 2022 6:07 am, edited 2 times in total.
Patrick Depoix
Architecte D.P.L.G. & Historien-chercheur en histoire de l'Architecture