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 12 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 9 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 7 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.