Help : Analytic calculation area of polygons.

[mhy3sx]

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 16 hours ago by mhy3sx

[dexus]

Makes me think of AreaG from GP_:

 

Maybe you can take some inspiration on the calculations in his code?

[mhy3sx]

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 14 hours ago by mhy3sx

[devitg]

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 . 

[devitg]

@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 12 hours ago by devitg
add attach file

[mhy3sx]

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

[devitg]

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

[BIGAL]

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.

[mhy3sx]

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