mhy3sx Posted yesterday at 01:38 PM Posted yesterday at 01:38 PM (edited) I have a code to calculate and write the area of close polygons. I want to update the code to support in calculations rectangular parallelepiped. The problem is that in trapezoid calculation is a bug and if i select a rectangular parallelepiped calculate the area as trapezoid. Can someone fix the code? (defun c:areacal ( / AcDoc Space nw_style js nb ent dxf_ent ptlst n old_textsize count app_txt surf cum_area pt_ins val_txt lst_bis l_4d max_d pos pt1 pt2 pt3 d1 d2 h t_spc nw_obj ent_text key label scl ht *error*) (vl-load-com) ; Define error handler (defun *error* (msg) (if (not (member msg '("Function cancelled" "quit / exit abort"))) (princ (strcat "\nError: " msg)) ) (setvar "OSMODE" 9) (mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1)) (if old_textsize (setvar "TEXTSIZE" old_textsize)) (vla-endundomark AcDoc) (princ) ) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (vla-startundomark AcDoc) (setvar "OSMODE" 0) ; Set scale and text height (setq scl (getvar "useri1")) (setq ht (* 0.003 scl)) ; Create ΚΕΙΜ_Layout layer if it doesn't exist (if (null (tblsearch "LAYER" "ΚΕΙΜ_Layout")) (vlax-put (vla-add (vla-get-layers AcDoc) "ΚΕΙΜ_Layout") 'color 7) ) ; Create ΚΕΙΜ_Layout text style if it doesn't exist (if (null (tblsearch "STYLE" "ΚΕΙΜ_Layout")) (progn (setq nw_style (vla-add (vla-get-textstyles AcDoc) "ΚΕΙΜ_Layout")) (mapcar '(lambda (pr val) (vlax-put nw_style pr val) ) (list 'FontFile 'Height 'ObliqueAngle 'Width 'TextGenerationFlag) (list (strcat (getenv "windir") "\\fonts\\arial.ttf") 0.0 0.0 1.0 0.0) ) ) ) ; Prompt for label prefix (setq label (getstring "\nInsert prefix (π.χ A,B,C..,etc): ")) (if (eq label "") (setq label "E")) ; Select polylines (prompt "\nSelect polylines one by one (press Enter to finish): ") (setq js (ssget '((0 . "LWPOLYLINE") (-4 . "<AND") (-4 . "&") (70 . 1) (-4 . ">") (90 . 2) (-4 . "<") (90 . 5) (-4 . "AND>")))) (if js (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) ) (if (eq n 4) (if (and (not (equal (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi) 1E-08)) (not (equal (rem (angle (cadr ptlst) (caddr ptlst)) pi) (rem (angle (cadddr ptlst) (car ptlst)) pi) 1E-08)) ) (ssdel ent js) ) ) ) ) ) (cond ((and js (> (sslength js) 0)) (sssetfirst nil js) (initget "Yes No") (if (not (eq (getkword "\n Insert calculations [Yes/No]? <Yes>: ") "No")) (progn (sssetfirst nil nil) (setq old_textsize (getvar "TEXTSIZE") count 0 app_txt "" cum_area 0.0 ) (setvar "TEXTSIZE" ht) ; Process polylines sequentially (0 to n-1) (setq nb 0) (while (< nb (sslength js)) (setq ent (ssname js 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 3)) ) (strcat label (itoa (setq count (1+ count))) " = " "1/2 x " (rtos max_d 2 2) " x " (rtos d1 2 2) " = " (rtos surf 2 2) " τ.μ.\\P" ) ) (if (and (equal (abs (- (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (car ptlst) (cadddr ptlst)) pi))) (* 0.5 pi) 1E-08) (equal (abs (- (rem (angle (cadr ptlst) (caddr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi))) (* 0.5 pi) 1E-08) ) (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 label (itoa (setq count (1+ count))) " = " (rtos d1 2 2) " x " (rtos d2 2 2) " = " (rtos surf 2 2) " τ.μ.\\P" ) ) (progn (if (equal (rem (angle (car ptlst) (cadr ptlst)) pi) (rem (angle (caddr ptlst) (cadddr ptlst)) pi) 1E-08) (setq d1 (atof (rtos (distance (car ptlst) (cadr ptlst)) 2 2)) d2 (atof (rtos (distance (caddr ptlst) (cadddr ptlst)) 2 2)) h (atof (rtos (distance (car ptlst) (inters (car ptlst) (polar (car ptlst) (+ (angle (car ptlst) (cadr ptlst)) (* 0.5 pi)) 1.0) (caddr ptlst) (cadddr ptlst) nil)) 2 2)) ) (setq d1 (atof (rtos (distance (cadr ptlst) (caddr ptlst)) 2 2)) d2 (atof (rtos (distance (car ptlst) (cadddr ptlst)) 2 2)) h (atof (rtos (distance (cadr ptlst) (inters (cadr ptlst) (polar (cadr ptlst) (+ (angle (cadr ptlst) (caddr ptlst)) (* 0.5 pi)) 1.0) (car ptlst) (cadddr ptlst) nil)) 2 2)) ) ) (setq surf (atof (rtos (* (+ d1 d2) h 0.5) 2 2)) cum_area (atof (rtos (+ surf cum_area) 2 2)) ) (strcat label (itoa (setq count (1+ count))) " = 1/2 x (" (rtos d1 2 2) " + " (rtos d2 2 2) ") x " (rtos h 2 2) " = " (rtos surf 2 2) " τ.μ.\\P" ) ) ) ) app_txt (strcat app_txt val_txt) ) (entmake (list '(0 . "TEXT") '(100 . "AcDbEntity") (cons 8 "ΚΕΙΜ_Layout") '(100 . "AcDbText") (cons 10 pt_ins) (cons 40 ht) (cons 1 (strcat label (itoa count))) (cons 50 (angle '(0 0 0) (getvar "UCSXDIR"))) '(41 . 1.0) '(51 . 0.0) (cons 7 "ΚΕΙΜ_Layout") '(71 . 0) '(72 . 1) (cons 11 pt_ins) (assoc 210 dxf_ent) '(100 . "AcDbText") '(73 . 2) ) ) (setq nb (1+ nb)) ) (initget "1 2") (setq t_spc (getkword "\n Insert calculations[1.Modelspace/2.Paperspace]? <1>: ")) (cond ((eq t_spc "2") (vla-put-ActiveSpace AcDoc acPaperSpace) (vla-put-MSpace AcDoc :vlax-false) (setq Space (vla-get-PaperSpace AcDoc)) (setvar "TEXTSIZE" 2.5) ) (T (vla-put-ActiveSpace AcDoc acModelSpace) (if (not (eq (getvar "TILEMODE") 1)) (vla-put-MSpace AcDoc :vlax-true)) (setq Space (vla-get-ModelSpace AcDoc)) (setvar "TEXTSIZE" ht) ) ) (setq nw_obj (vla-addMtext Space (vlax-3d-point (trans (getvar "VIEWCTR") 1 0)) 0.0 (strcat app_txt label "ολ = " (rtos cum_area 2 2) " τ.μ.") ) ) (mapcar '(lambda (pr val) (vlax-put nw_obj pr val) ) (list 'AttachmentPoint 'Height 'DrawingDirection 'StyleName 'Layer 'Rotation) (list 1 (getvar "TEXTSIZE") 5 "ΚΕΙΜ_Layout" "ΚΕΙΜ_Layout" 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")) ) ; Reset system variables (mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1)) (setvar "OSMODE" 9) (vla-endundomark AcDoc) (princ) ) Thanks test.dwg Edited yesterday at 01:39 PM by mhy3sx Quote
dexus Posted yesterday at 02:41 PM Posted yesterday at 02:41 PM Makes me think of AreaG from GP_: Maybe you can take some inspiration on the calculations in his code? Quote
mhy3sx Posted yesterday at 02:43 PM Author Posted yesterday at 02:43 PM (edited) I dont want to insert the calculations in table.I want to insert as mtext. And I want the calculations with the dimension of eatch polygon not by coordinates. Any ideas Thanks Edited yesterday at 04:23 PM by mhy3sx Quote
devitg Posted yesterday at 05:22 PM Posted yesterday at 05:22 PM 2 hours ago, mhy3sx said: I dont want to insert the calculations in table.I want to insert as mtext. And I want the calculations with the dimension of eatch polygon not by coordinates. Any ideas Thanks @mhy3sx Where you need to put area value . Quote
devitg Posted yesterday at 06:02 PM Posted yesterday at 06:02 PM (edited) @mhy3sx please upload the sample DWG with a mtext sample Mean while try the lisp file , it will put the area value at each polyline geografic center get area by calculation.dwg get-area.LSP Edited yesterday at 06:12 PM by devitg add attach file Quote
mhy3sx Posted yesterday at 06:17 PM Author Posted yesterday at 06:17 PM I need to insert the calculation ananylic in specific drawings. If someone check the drawing ,need to know how I do the calculations.Thats why I want to update this code. Thanks Quote
devitg Posted yesterday at 09:24 PM Posted yesterday at 09:24 PM 3 hours ago, mhy3sx said: I need to insert the calculation analytic in specific drawings. If someone check the drawing ,need to know how I do the calculations.Thats why I want to update this code. Thanks Lisp give the correct Area The lsp have some error , I fix it as far as I know to do . See text file atached , dwg and lisp fixed You have to arrange ; Set scale and text height (setq scl (getvar "useri1")) (setq ht (* 0.00003 scl)) As you need fixed area-cal.LSP to check.txt get area by calculation.dwg Quote
BIGAL Posted 21 hours ago Posted 21 hours ago The get area by co-ordinates method is a known mathematical formula why not just paste that into your dwg as a statement. Have a test shape like a square, with the example of calculations. Second comment this has been asked for before many years ago, it must be a particular country land title standard that must be shown. Sorry no idea where to start looking for the previous posts, maybe here or Forums/Autodesk. Quote
mhy3sx Posted 16 hours ago Author Posted 16 hours ago Hi devitg, You delete parts of the original code . I use ; Set scale and text height (setq scl (getvar "useri1")) (setq ht (* 0.00003 scl)) To set the scale for a lot of the lisp I use , and I need this part too (initget "1 2") ;;; (setq t_spc (getkword "\n Insert calculations[1.Modelspace/2.Paperspace]? <1>: ")) I test the code you upload but The calculation on trapezoid is not fixed because can not understand that the paralilogram (a2) is not a trapezoid (a1) because the code check only if the lines is pararell and calculate the area of the trapezoid. Perhaps need son anngle check to understamd if it is paralilogram or trapezoid. Thanks Quote
CivilTechSource Posted 9 hours ago Posted 9 hours ago (edited) We are in 2025, do we still need to show the work? Would it not be easier to write a lisp that prompts you to select each side of polygon by specifying starting and end point and then you can have the lisp do a check between if trapezoid or parallelogram and then put in text the formula substituting the lengths? The below is AI generated code that seems to work fine in terms of differentiating between triangle rectangle trapezoid and parallelogram. The mtext showing the work has some boxes not sure why. (defun C:POLYAREA (/ pt1 pt2 pt3 pt4 pts shape-type area calc-text insert-pt) ;; Function to calculate distance between two points (defun get-distance (p1 p2) (sqrt (+ (expt (- (car p2) (car p1)) 2) (expt (- (cadr p2) (cadr p1)) 2)))) ;; Function to calculate area using shoelace formula (defun shoelace-area (point-list) (setq n (length point-list)) (setq area 0.0) (setq i 0) (while (< i n) (setq j (if (= i (1- n)) 0 (1+ i))) (setq xi (car (nth i point-list))) (setq yi (cadr (nth i point-list))) (setq xj (car (nth j point-list))) (setq yj (cadr (nth j point-list))) (setq area (+ area (* xi yj))) (setq area (- area (* xj yi))) (setq i (1+ i))) (abs (/ area 2.0))) ;; Function to check if vectors are parallel (for parallelogram/rectangle check) (defun vectors-parallel (v1 v2 tolerance) (setq cross-product (abs (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2))))) (< cross-product tolerance)) ;; Function to check if vectors are perpendicular (for rectangle check) (defun vectors-perpendicular (v1 v2 tolerance) (setq dot-product (+ (* (car v1) (car v2)) (* (cadr v1) (cadr v2)))) (< (abs dot-product) tolerance)) ;; Function to get vector from two points (defun get-vector (p1 p2) (list (- (car p2) (car p1)) (- (cadr p2) (cadr p1)))) ;; Function to identify quadrilateral type (defun identify-quad (p1 p2 p3 p4) (setq v1 (get-vector p1 p2)) ; Side 1 (setq v2 (get-vector p2 p3)) ; Side 2 (setq v3 (get-vector p3 p4)) ; Side 3 (setq v4 (get-vector p4 p1)) ; Side 4 (setq tolerance 0.001) ;; Check if opposite sides are parallel (setq opposite1-parallel (vectors-parallel v1 v3 tolerance)) (setq opposite2-parallel (vectors-parallel v2 v4 tolerance)) (cond ;; Rectangle: opposite sides parallel AND adjacent sides perpendicular ((and opposite1-parallel opposite2-parallel (vectors-perpendicular v1 v2 tolerance)) "Rectangle") ;; Parallelogram: opposite sides parallel ((and opposite1-parallel opposite2-parallel) "Parallelogram") ;; Trapezoid: one pair of opposite sides parallel ((or opposite1-parallel opposite2-parallel) "Trapezoid") ;; General quadrilateral (t "Quadrilateral"))) ;; Function to create calculation text for triangle (defun triangle-calc-text (p1 p2 p3 area) (setq a (get-distance p1 p2)) (setq b (get-distance p2 p3)) (setq c (get-distance p3 p1)) (setq s (/ (+ a b c) 2.0)) ; semi-perimeter (setq sa (- s a)) (setq sb (- s b)) (setq sc (- s c)) (strcat "TRIANGLE AREA CALCULATION\\P" "Using Heron's Formula:\\P" "Side a = " (rtos a 2 3) " units\\P" "Side b = " (rtos b 2 3) " units\\P" "Side c = " (rtos c 2 3) " units\\P" "Semi-perimeter s = " (rtos s 2 3) " units\\P" "Area = √(s(s-a)(s-b)(s-c))\\P" "Area = √(" (rtos s 2 3) "×" (rtos sa 2 3) "×" (rtos sb 2 3) "×" (rtos sc 2 3) ")\\P" "Area = √" (rtos (* s sa sb sc) 2 3) "\\P" "Area = " (rtos area 2 3) " square units")) ;; Function to create calculation text for rectangle (defun rectangle-calc-text (p1 p2 p3 p4 area) (setq width (get-distance p1 p2)) (setq height (get-distance p2 p3)) (strcat "RECTANGLE AREA CALCULATION\\P" "Width = " (rtos width 2 3) " units\\P" "Height = " (rtos height 2 3) " units\\P" "Area = Width × Height\\P" "Area = " (rtos width 2 3) " × " (rtos height 2 3) "\\P" "Area = " (rtos area 2 3) " square units")) ;; Function to create calculation text for parallelogram (defun parallelogram-calc-text (p1 p2 p3 p4 area) (setq base (get-distance p1 p2)) ;; Calculate height using area formula: Area = base × height (setq height (/ area base)) (strcat "PARALLELOGRAM AREA CALCULATION\\P" "Base = " (rtos base 2 3) " units\\P" "Height = " (rtos height 2 3) " units\\P" "Area = Base × Height\\P" "Area = " (rtos base 2 3) " × " (rtos height 2 3) "\\P" "Area = " (rtos area 2 3) " square units")) ;; Function to create calculation text for trapezoid (defun trapezoid-calc-text (p1 p2 p3 p4 area) (strcat "TRAPEZOID AREA CALCULATION\\P" "Using coordinate method (Shoelace formula)\\P" "Point 1: (" (rtos (car p1) 2 3) ", " (rtos (cadr p1) 2 3) ")\\P" "Point 2: (" (rtos (car p2) 2 3) ", " (rtos (cadr p2) 2 3) ")\\P" "Point 3: (" (rtos (car p3) 2 3) ", " (rtos (cadr p3) 2 3) ")\\P" "Point 4: (" (rtos (car p4) 2 3) ", " (rtos (cadr p4) 2 3) ")\\P" "Area = ½|∑(xᵢyᵢ₊₁ - xᵢ₊₁yᵢ)|\\P" "Calculation: ½|(" (rtos (car p1) 2 3) "×" (rtos (cadr p2) 2 3) "-" (rtos (car p2) 2 3) "×" (rtos (cadr p1) 2 3) ") + " "(" (rtos (car p2) 2 3) "×" (rtos (cadr p3) 2 3) "-" (rtos (car p3) 2 3) "×" (rtos (cadr p2) 2 3) ") + " "(" (rtos (car p3) 2 3) "×" (rtos (cadr p4) 2 3) "-" (rtos (car p4) 2 3) "×" (rtos (cadr p3) 2 3) ") + " "(" (rtos (car p4) 2 3) "×" (rtos (cadr p1) 2 3) "-" (rtos (car p1) 2 3) "×" (rtos (cadr p4) 2 3) ")|\\P" "Area = " (rtos area 2 3) " square units")) ;; Main program starts here (princ "\\nPolygon Area Calculator") (princ "\\nSelect points in order (clockwise or counterclockwise)") ;; Get first point (if (setq pt1 (getpoint "\\nSelect first point: ")) (progn ;; Get second point (if (setq pt2 (getpoint pt1 "\\nSelect second point: ")) (progn ;; Get third point (if (setq pt3 (getpoint pt2 "\\nSelect third point: ")) (progn ;; Check if user wants to add a fourth point (setq pt4 (getpoint pt3 "\\nSelect fourth point (or press Enter for triangle): ")) (if pt4 ;; Four points - quadrilateral (progn (setq pts (list pt1 pt2 pt3 pt4)) (setq shape-type (identify-quad pt1 pt2 pt3 pt4)) (setq area (shoelace-area pts)) ;; Create appropriate calculation text (cond ((= shape-type "Rectangle") (setq calc-text (rectangle-calc-text pt1 pt2 pt3 pt4 area))) ((= shape-type "Parallelogram") (setq calc-text (parallelogram-calc-text pt1 pt2 pt3 pt4 area))) (t (setq calc-text (trapezoid-calc-text pt1 pt2 pt3 pt4 area)))) (princ (strcat "\\nShape identified: " shape-type)) (princ (strcat "\\nArea: " (rtos area 2 3) " square units"))) ;; Three points - triangle (progn (setq pts (list pt1 pt2 pt3)) (setq shape-type "Triangle") (setq area (shoelace-area pts)) (setq calc-text (triangle-calc-text pt1 pt2 pt3 area)) (princ (strcat "\\nShape identified: " shape-type)) (princ (strcat "\\nArea: " (rtos area 2 3) " square units")))) ;; Get insertion point for MText (if (setq insert-pt (getpoint "\\nSelect point to insert calculation text: ")) (progn ;; Create MText entity (entmake (list (cons 0 "MTEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbMText") (cons 10 insert-pt) ; insertion point (cons 40 2.5) ; text height (cons 41 50.0) ; reference rectangle width (cons 71 1) ; attachment point (top left) (cons 72 5) ; drawing direction (cons 1 calc-text) ; text string (cons 7 "STANDARD") ; text style (cons 210 '(0.0 0.0 1.0)))) ; normal vector (princ "\\nCalculation text inserted successfully!")) (princ "\\nText insertion cancelled."))) (princ "\\nThird point required.")) (princ "\\nSecond point required.")) (princ "\\nFirst point required.")) (princ)) ) ) ;; Command to run the function (princ "\\nPolygon Area Calculator loaded. Type POLYAREA to run.") (princ) Edited 9 hours ago by CivilTechSource Quote
mhy3sx Posted 5 hours ago Author Posted 5 hours ago Hi CivilTechSource , I test your code but if you test it in my dwg will see that calculate a2 area as trapezoid !!! Thanks Quote
devitg Posted 1 hour ago Posted 1 hour ago 3 hours ago, mhy3sx said: Hi CivilTechSource , I test your code but if you test it in my dwg will see that calculate a2 area as trapezoid !!! Thanks @mhy3sx it calculate a2 as a trapezoid , because it is not a rectangle , short side are not parallel to be or no tobe a trapezoid.dwg Quote
Recommended Posts
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.