auto area calculation table

September 1, 2021

On 12/03/2019 at 13:40, rlx said:

If you want a block just explode the table and make it a block. Routine places length of all vertices at this time. It's not hard to remove duplicates but to foolproof let the routine decide which one to remove I haven't cracked yet and not very important , not to me anyway because right now I have another appie in need of my help (else I have to do all the work myself and that's not what I had in mind when I got out of bed at 5 am this morning)

hi rlx, would you mind sharing this file again please, is not anymore available,

Thanks a lot,

Quote

Harshad2.lspUnavailable

September 1, 2021

here ya go , one 2,5 year old file (hope you don't have any questions because every weekend I wipe my brain )

Harshad2.lsp

November 11, 2021

hey can you change the dimension precision to 3 digits in the excel table?

November 11, 2021

just change precision of rtos function (pretty basic lisp stuf)

rtos (AutoLISP) : Converts a number into a string

Signature : (rtos number [mode [precision]])

number
Type: Integer or Real

A numeric value.

mode
Type: Integer

Linear units mode. The mode corresponds to the values allowed for the AutoCAD LUNITS system variable.

The mode can be one of the following numbers:

1 -- Scientific

2 -- Decimal

3 -- Engineering (feet and decimal inches)

4 -- Architectural (feet and fractional inches)

5 -- Fractional

precision
Type: Integer

Precision used to format the returned value.

these lines in lsp file use the rtos function :

line 61 : (rtos (/ (last x) 1000) 2 3)
line 72 : (rtos (/ (distance p1 p2) 1000) 2 3)
line 246 : (rtos (caadr item) 2 3)
line 247 : (rtos (if (cadadr item)(cadadr item)(caadr item)) 2 3)
line 252 : (rtos area 2 3)
line 257 : (rtos total-area 2 3)

just change (rtos blabla 2 2) in (rtos blabla 2 3)

November 12, 2021

The quick in this case use a pattern to ensure.

January 9, 2022

hi rlx. Nice code, Can you a change in your code. Not indert a table but text with analytic calculation and insert in layout with text size 2.50

for example

E1 = 1/2 x 59.328 x 102.361 = 3036.410 sq.m
E2 = 1/2 x 16.672 x 85.953 = 716.521 sq.m
E3 = 1/2 x 73.395 x 97.338 = 3756.397 sq.m
E4 = 1/2 x 26.281 x 97.338 = 1279.042 sq.m
Tota; = 3036.410 + 716.521 + 3756.397 + 1279.042 = 8785.37 sq.m

Thanks

January 9, 2022

Its about time you started to answer your own questions your not a new poster. Learn about lisp.

January 9, 2022

Hi BIGAL. I did some changes to the code.But i dont know how to convert the table to text and how to insert the new text in layout.

; rlx 11-mrt-2019 - https://www.cadtutor.net/forum/topic/66987-auto-area-calculation-table/

(defun c:t3 ( / doc spc i text-height ascii-mode ss polly lst id)
(setq scl (getint "\n give scale (50,100,200,250,500,etc) :"))
 (setq ht1(* 0.00175 scl))
 (setq ht2(* 0.003 scl))
(command "_layer" "_m" "Area" "_c" "6" "" "")
  (setq doc (vla-get-activedocument (vlax-get-acad-object)) spc (vla-get-block (vla-get-activelayout doc))
        i 0 text-height ht1)(setvar 'textsize text-height)
  (defun *error* (s)(princ s)(princ"\nProgramme has stopped")(princ))
  (initget "Yes No") (setq ascii-mode (getkword "\nUse letters in table? <Y>: "))
  (if (member ascii-mode '("Yes" nil))(setq ascii-mode t)(setq ascii-mode nil))
  (prompt "\nSelect polylines :")
  (if (and (setq ss (ssget ":L" '((0 . "LWPOLYLINE")))) (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
    (foreach polly ss
      (setq polly-points (Get_Polly_Points polly) polly-center (Get_Polly_Center spc polly))
      (cond
        ; type 1 : square
        ((and (> (length polly-points) 3) (square-p polly-points) (no-arc polly))
         (setq id 1 lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) id) lst)))
        ; type 2 : rectangular triangle
        ((and (= 3 (length polly-points))(triangle-p polly-points)(90-p polly-points)(no-arc polly))
         (setq id 2 lst (cons (list (setq i (1+ i)) (Get_Triangle_Polly_Lengths polly-points) id) lst)))
         ; type 3 : non rectangular triangle
        ((and (= 3 (length polly-points))(triangle-p polly-points)(not (90-p polly-points))(no-arc polly))
         ;(setq polly-points (LM:minboundingbox (ssadd polly) 0.01))
         ;(setq lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) 3) lst))
         (setq big-polly (get_big_polly polly-points)) ; point list (p1 p2 p3...) -> (dist p2 p3)
         (setq up-polly (car (vl-remove-if '(lambda(x)(member x (cdr big-polly))) polly-points))); point not on long side
         (setq down-polly (LM:ProjectPointToLine up-polly (cadr big-polly)(caddr big-polly))); perp. point on long side
         (setq polly-points (list (cadr big-polly) up-polly down-polly))
         (setq id 3 lst (cons (list (setq i (1+ i)) (list (/ (car big-polly) 1)(/ (distance up-polly down-polly) 1)) id) lst))
         (Put_Polly_Length spc (cadr big-polly) (caddr big-polly) ht1)
         (Put_Polly_Length spc up-polly down-polly ht1)
        )
        ; type 4 : ask me if I give a <sensored>
        (t (setq polly-points (LM:minboundingbox (ssadd polly) 0.01))
           (setq id 4 lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) id) lst)))
      )
      (place_text (if ascii-mode (itol i)(itoa i)) polly-center ht2); ht2 = text height
      (if (/= id 3) (Put_Polly_Sizes (Get_Polly_Sizes polly-points) polly-center spc ht1)) ; ht1 - text height
    )
  )
  (vla-Regen doc acActiveViewport)
  (place_table (vl-sort lst (function (lambda (a b)(< (car a)(car b))))))
  (princ)
)

; s = string , pt is point , th = text height
(defun place_text (s pt th / to)
  (setq to (vla-addtext spc s (vlax-3d-point pt) th))
  (mapcar '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list to p v)))
           (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
           (list acAlignmentRight (vlax-3d-point pt) acAlignmentMiddle 0 acRed)
  )
)

; l = vertice list ((ang midp length)...) c = center of gravity , s = space , th = text height
(defun Put_Polly_Sizes (l c s th / a x o p)
  (foreach x l
    (setq a (fang (car x)))
    ; place text on inside of the polyline
    ;(setq p (vlax-3d-point (polar (cadr x) (angle (cadr x) c) th)) o (vla-addtext s (rtos (last x) 2 2) p th))
    ; place text on middelpoint of vertice
    (setq p (vlax-3d-point (cadr x)) o (vla-addtext s (rtos (/ (last x) 1) 2 2) p th))
    (mapcar
      '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list o p v)))
       (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
       (list acAlignmentRight p acAlignmentMiddle a acMagenta)
    )
  ) 
)

; put length on mid point vertice
(defun Put_Polly_Length (spc p1 p2 th / a d o p )
  (setq a (fang (angle p1 p2)) p (between p1 p2) d (rtos (/ (distance p1 p2) 1) 2 2)
        o (vla-addtext spc d (vlax-3d-point p) th))
  (mapcar '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list o p v)))
    (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
          (list acAlignmentRight (vlax-3d-point p) acAlignmentMiddle a acMagenta))
)


(defun fang (a)(if (and (>= a (* 0.5 pi)) (<= a (* 1.5 pi)))(+ a pi) a))

(defun between (pt1 pt2)(mapcar '(lambda (x y) (/ (+ x y) 2)) pt1 pt2))

(defun itol (i)(if (< i 27)(chr (+ 64 i))(strcat (itol (/ (1- i) 26))(itol (1+ (rem (1- i) 26))))))

; l is point list , return list with angle , midpoint & length for each vertice
(defun Get_Polly_Sizes (l)
  (mapcar '(lambda (a b) (list (angle a b) (mapcar '(lambda (x y) (/ (+ x y) 2)) a b)(distance a b)))
          l (append (cdr l) (list (car l)))))

; returns largest distance between point from a point list (p1 p2 p3...) -> (dist p2 p3)
; test : (setq lst (Get_Big_Polly (get_polly_points (car (entsel)))))
(defun get_big_polly (l)
  (car (vl-sort (mapcar '(lambda (a b) (cons (distance a b) (list a b)))
   l (append (cdr l) (list (car l)))) ''((a b)(> (car a)(car b))))))

; l = list with angle, midpoint & length for each vertex (get_polly_sizes (get_polly_points(car (entsel))))
; driehoek 0,10 / 30,30 / 40,10
; bv ((0.588003 (15.0 20.0 0.0) 36.0555) (5.17604 (35.0 20.0 0.0) 22.3607) (3.14159 (20.0 10.0 0.0) 40.0))
; zoek nu laagste mid point en meest linkse
; c = centerpoint of gravity '(x y z)
; vl = vertex list ((l1 p1 p2) (l2 p2 p3) (l3 p3 p1)...)
(defun get_squared ( l c / vl )
  ; get (unsorted) list ((vertex-length p1 p2) . . .)
  (setq vl (mapcar '(lambda (a b) (cons (distance a b) (list a b))) l (append (cdr l) (list (car l))))
        x- (apply 'min (mapcar 'cadr vl)) y- (apply 'min (mapcar 'caddr vl)))
  ; most left vertex in square will have smallest x and lowest will have smallest y
)


;;; Gile (setq lst (get_polly_points (car (entsel))))
(defun Get_Polly_Points (pl / pa pt lst)(vl-load-com)
  (setq	pa (if (vlax-curve-IsClosed pl)(vlax-curve-getEndParam pl)(+ (vlax-curve-getEndParam pl) 1)))
  (while (setq pt (vlax-curve-getPointAtParam pl (setq pa (- pa 1))))(setq lst (cons pt lst))))

; s = space , e = polly (ent or obj)
(defun Get_Polly_Center ( s e / o r c )
  (or (= (type e) 'VLA-OBJECT) (setq o (vlax-ename->vla-object e)))
  (setq r (vlax-invoke s 'addRegion (list o)) c (vlax-get (car r) 'Centroid))
  (vla-delete (car r))(trans c 1 (vlax-get o 'Normal)))

;checks if entity (polyline) contains an arc (no-arc (car (entsel)))
(defun no-arc (e) (zerop (apply '+ (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget e))))))

; sorts point list on length and removes the longest
; (Get_Triangle_Polly_Lengths (get_polly_points (car (entsel))))
(defun Get_Triangle_Polly_Lengths (l / r)
  (cdr (vl-sort (mapcar '(lambda (a b) (/ (distance a b) 1)) l (append (cdr l) (list (car l)))) '>)))

; (Get_Square_Polly_Lengths (get_polly_points (car (entsel))))
(defun Get_Square_Polly_Lengths (l / r)
  (cddr (mapcar '(lambda (a b) (/ (distance a b) 1)) l (append (cdr l) (list (car l))))))

;;;remove duplicates
(defun rdup (i / o) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) i))

;;; http://www.lee-mac.com/mathematicalfunctions.html#geomproj
;;; Project Point onto Line  -  Lee Mac - Projects pt onto the line defined by p1,p2
(defun LM:ProjectPointToLine ( pt p1 p2 / nm )
  (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm))
  (trans (list (car p1) (cadr p1) (caddr pt)) nm 0)
)

; https://www.cadtutor.net/forum/topic/60652-lisp-minimum-bounding-box-for-rotated-attributeblock/

;; Minimum Bounding Box  -  Lee Mac
;; Returns the WCS coordinates describing the minimum bounding rectangle
;; surrounding all objects in a supplied selection set.
;; sel - [sel] selection set to process
;; tol - [rea] precision of calculation, 0 < tol < 1

(defun LM:minboundingbox ( sel tol / ang box bx1 bx2 cen idx lst obj rtn )
  (if (and sel (< 0.0 tol 1.0))
    (progn
      (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b)))))
          (setq lst (cons (vla-copy obj) lst))))
      (if lst
        (progn
          (setq box (LM:objlstboundingbox lst) tol (* tol pi)
                cen (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
                bx1 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box))) rtn (list 0.0 box) ang 0.0)
          (while (< (setq ang (+ ang tol)) pi)
            (foreach obj lst (vlax-invoke obj 'rotate cen tol))
            (setq box (LM:objlstboundingbox lst) bx2 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box))))
            (if (< bx2 bx1) (setq bx1 bx2 rtn (list ang box))))
          (foreach obj lst (vla-delete obj))
          (LM:rotatepoints (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (apply b (cdr rtn))) a))
                                   '((caar cadar) (caadr  cadar) (caadr cadadr) (caar  cadadr))) cen (- (car rtn)))
        )
      )
    )
  )
)

;; Object List Bounding Box  -  Lee Mac
;; Returns the lower-left and upper-right points of a rectangle bounding a list of objects

(defun LM:objlstboundingbox ( lst / llp ls1 ls2 urp )
  (foreach obj lst
    (vla-getboundingbox obj 'llp 'urp)
    (setq ls1 (cons (vlax-safearray->list llp) ls1) ls2 (cons (vlax-safearray->list urp) ls2)))
  (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)

;; Rotate Points  -  Lee Mac - Rotates a list of points about a supplied point by a given angle
(defun LM:rotatepoints ( lst bpt ang / mat vec )
  (setq mat (list (list (cos ang)(sin (- ang)) 0.0)(list (sin ang)(cos ang) 0.0) '(0.0 0.0 1.0)))
  (setq vec (mapcar '- bpt (mxv mat bpt)))(mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) vec)) lst))

;; Matrix x Vector - Vladimir Nesterovsky - Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )  (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m))

; test if all angles from a polyline add up to 360 degrees (* pi 2). Sometimes polylines have 'broken' vertices so ang=0
; partially based on LM:GetInsideAngle - test : (square-p (get_polly_points (car (entsel))))
(defun square-p (l)
  (equal (rem (apply '+ (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
    (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
      (append (cddr l)(list (car l) (cadr l))))) pi) 0.0 0.1))


; test if all angles from a polyline add up to 180 degrees (pi). Fails when one of 3 vertices containa a bulge
; so additional bulge test required - test : (triangle-p (get_polly_points (car (entsel))))
(defun triangle-p (l)
  (equal pi (apply '+ (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
    (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
      (append (cddr l)(list (car l) (cadr l))))) 0.1))

; test if polyline has 90 degree angle - test : (90-p (get_polly_points (car (entsel))))
(defun 90-p (l)
  (vl-some (function (lambda (a)(equal a (/ pi 2) 0.01)))
    (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
      (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
        (append (cddr l)(list (car l) (cadr l))))))


(defun place_table ( lst / total-area pt acm tbl col y calc-type-list fac row col area)
  (setq total-area 0 pt (getpoint "\nSelect point to place table : ") colums 5)
  (setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
  ; makes a table with as many rows as length lst plus 3 (2 for the title and headers plus 1 for total)
  ; 2 columns, row height 5 and cell width 20
  (setq tbl (vla-AddTable spc (vlax-3d-point pt) (+ 3 (length lst)) colums 5 25)) 
  (vla-setcelltextheight tbl 0 0 2.5) ; title text height 2.5, to stand out
  (vla-put-colorindex acm 7)
  (repeat (setq row (vla-get-rows tbl))
    (setq row (1- row))
    (repeat (setq col (vla-get-columns tbl))
      (vla-setcelltextheight tbl row (setq col (1- col)) 2.5)
      (vla-setCellAlignment tbl row col 5) ; center text
      (vla-setcellcontentcolor tbl row col acm)
    )
  )
  
  (vla-setText tbl 0 0 "Areas") ; fill in title
  (vla-setText tbl 1 0 "Block") ; fill in headers
  (vla-setText tbl 1 1 "a")
  (vla-setText tbl 1 2 "b")
  (vla-setText tbl 1 3 "c")
  (vla-setText tbl 1 4 "Area")
  ;(setq row 2 calc-type-list '((1 . "")(2 . "0.5")(3 . "0.5")(4 . "0.66")))
  (setq row 2 calc-type-list '((1 . "")(2 . "1/2")(3 . "1/2")(4 . "2/3")))
  ; lst = ( ([polly-no] [(l1 l2)] [calc-type]) ...)
  (foreach item lst
    (vla-setText tbl row 0 (if ascii-mode (itol (car item))(itoa (car item)))) ; block no.
    (vla-setText tbl row 1 (rtos (caadr item) 2 2)) ; lenght 1
    (vla-setText tbl row 2 (rtos (if (cadadr item)(cadadr item)(caadr item)) 2 2)); length 2
    (vla-setText tbl row 3 (setq fac (cdr (assoc (last item) calc-type-list))))
    (if (eq fac "")
      (setq area (* (caadr item)(if (cadadr item)(cadadr item)(caadr item))))
      (setq area (* (atof fac) (caadr item)(if (cadadr item)(cadadr item)(caadr item)))))
    (vla-setText tbl row 4 (rtos area 2 2)) (setq total-area (+ total-area area))
    (setq row (1+ row))
  )

  ; still have to add row with total
  (vla-setText tbl row 0 "Total")(vla-setText tbl row 4 (rtos total-area 2 2))
  
  ; put the color (white)
  
 ;(vla-put-colorindex acm 7)
  (vla-put-regeneratetablesuppressed tbl :vlax-true)
 (repeat (setq row (vla-get-rows tbl))
  (setq row (1- row))(repeat (setq col (vla-get-columns tbl))))
 (vla-put-color tbl 7)

 (vla-put-regeneratetablesuppressed tbl :vlax-false)
  
  (vlax-release-object tbl)      
  (vlax-release-object spc)    
)
; (c:t3)

Thanks

January 11, 2022

any option?

January 11, 2022

; rlx 11-mrt-2019 - https://www.cadtutor.net/forum/topic/66987-auto-area-calculation-table/

;|
Not table insert
text with analytic calculation / insert text in layout with size 2.50

E1 = 1/2 x 59.328 x 102.361 = 3036.410 sq.m
E2 = 1/2 x 16.672 x 85.953 = 716.521 sq.m
E3 = 1/2 x 73.395 x 97.338 = 3756.397 sq.m
E4 = 1/2 x 26.281 x 97.338 = 1279.042 sq.m
Total = 3036.410 + 716.521 + 3756.397 + 1279.042 = 8785.37 sq.m
|;


(defun c:t4 ( / doc spc i text-height ht1 ascii-mode ss polly lst id)
;;; (setq scl (getint "\n give scale (50,100,200,250,500,etc) :")) (setq ht1(* 0.00175 scl)) (setq ht2(* 0.003 scl))
(command "_layer" "_m" "Area" "_c" "6" "" "")
  (setq doc (vla-get-activedocument (vlax-get-acad-object)) spc (vla-get-block (vla-get-activelayout doc))
        i 0 text-height 2.5 ht1 2.5)(setvar 'textsize text-height)
  (defun *error* (s)(princ s)(princ"\nProgramme has stopped")(princ))
  ;;; (initget "Yes No") (setq ascii-mode (getkword "\nUse letters for id? <Y>: "))
  ;;; (if (member ascii-mode '("Yes" nil))(setq ascii-mode t)(setq ascii-mode nil))
  (setq ascii-mode t)
  (prompt "\nSelect polylines :")
  (if (and (setq ss (ssget ":L" '((0 . "LWPOLYLINE")))) (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))
    (foreach polly ss
      (setq polly-points (Get_Polly_Points polly) polly-center (Get_Polly_Center spc polly))
      (cond
        ; type 1 : square
        ((and (> (length polly-points) 3) (square-p polly-points) (no-arc polly))
         (setq id 1 lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) id) lst)))
        ; type 2 : rectangular triangle
        ((and (= 3 (length polly-points))(triangle-p polly-points)(90-p polly-points)(no-arc polly))
         (setq id 2 lst (cons (list (setq i (1+ i)) (Get_Triangle_Polly_Lengths polly-points) id) lst)))
         ; type 3 : non rectangular triangle
        ((and (= 3 (length polly-points))(triangle-p polly-points)(not (90-p polly-points))(no-arc polly))
         ;(setq polly-points (LM:minboundingbox (ssadd polly) 0.01))
         ;(setq lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) 3) lst))
         (setq big-polly (get_big_polly polly-points)) ; point list (p1 p2 p3...) -> (dist p2 p3)
         (setq up-polly (car (vl-remove-if '(lambda(x)(member x (cdr big-polly))) polly-points))); point not on long side
         (setq down-polly (LM:ProjectPointToLine up-polly (cadr big-polly)(caddr big-polly))); perp. point on long side
         (setq polly-points (list (cadr big-polly) up-polly down-polly))
         (setq id 3 lst (cons (list (setq i (1+ i)) (list (/ (car big-polly) 1)(/ (distance up-polly down-polly) 1)) id) lst))
         (Put_Polly_Length spc (cadr big-polly) (caddr big-polly) ht1)
         (Put_Polly_Length spc up-polly down-polly ht1)
        )
        ; type 4 : ask me if I give a <sensored>
        (t (setq polly-points (LM:minboundingbox (ssadd polly) 0.01))
           (setq id 4 lst (cons (list (setq i (1+ i)) (rdup (Get_Square_Polly_Lengths polly-points)) id) lst)))
      )
      ;;; (place_text (if ascii-mode (itol i)(itoa i)) polly-center ht2); ht2 = text height
      (place_mtext polly-center (list (if ascii-mode (itol i)(itoa i))  (cadr (car lst))))
      (if (/= id 3) (Put_Polly_Sizes (Get_Polly_Sizes polly-points) polly-center spc ht1)) ; ht1 - text height
    )
  )
  (vla-Regen doc acActiveViewport)
  ;;; (place_table (vl-sort lst (function (lambda (a b)(< (car a)(car b))))))
  (princ)
)

; s = string , pt is point , th = text height
(defun place_text (s pt th / to)
  (setq to (vla-addtext spc s (vlax-3d-point pt) th))
  (mapcar '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list to p v)))
           (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
           (list acAlignmentRight (vlax-3d-point pt) acAlignmentMiddle 0 acRed)
  )
)

;;; E1 = 1/2 x 59.328 x 102.361 = 3036.410 sq.m / (rtos (/ (last x) 1000) 2 3)
;;; pt = insertion point , d = ($ (# #)) , height (h) set on 2.5 (dxf code 40)
(defun place_mtext (pt d / a b h) (setq a (car d) b (rtos (* 0.5 (car (cadr d))(cadr (cadr d))) 2 3) h 2.5)
  (entmakex (list '(0 . "MTEXT") '(100 . "AcDbEntity") '(100 . "AcDbMText")(cons 10 pt)(cons 1 (strcat a "\\P" b))
    (cons 90 1) (cons 63 7) (cons 40 h) (cons 71 5) '(72 . 5) '(441 . 0)(cons 410 (getvar 'ctab)))))


; l = vertice list ((ang midp length)...) c = center of gravity , s = space , th = text height
(defun Put_Polly_Sizes (l c s th / a x o p)
  (foreach x l
    (setq a (fang (car x)))
    ; place text on inside of the polyline
    ;(setq p (vlax-3d-point (polar (cadr x) (angle (cadr x) c) th)) o (vla-addtext s (rtos (last x) 2 2) p th))
    ; place text on middelpoint of vertice
    (setq p (vlax-3d-point (cadr x)) o (vla-addtext s (rtos (/ (last x) 1) 2 2) p th))
    (mapcar
      '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list o p v)))
       (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
       (list acAlignmentRight p acAlignmentMiddle a acMagenta)
    )
  ) 
)

; put length on mid point vertice
(defun Put_Polly_Length (spc p1 p2 th / a d o p )
  (setq a (fang (angle p1 p2)) p (between p1 p2) d (rtos (/ (distance p1 p2) 1) 2 2)
        o (vla-addtext spc d (vlax-3d-point p) th))
  (mapcar '(lambda (p v)(vl-catch-all-apply 'vlax-put-property (list o p v)))
    (list 'alignment 'textalignmentpoint 'alignment 'rotation 'color)
          (list acAlignmentRight (vlax-3d-point p) acAlignmentMiddle a acMagenta))
)


(defun fang (a)(if (and (>= a (* 0.5 pi)) (<= a (* 1.5 pi)))(+ a pi) a))

(defun between (pt1 pt2)(mapcar '(lambda (x y) (/ (+ x y) 2)) pt1 pt2))

(defun itol (i)(if (< i 27)(chr (+ 64 i))(strcat (itol (/ (1- i) 26))(itol (1+ (rem (1- i) 26))))))

; l is point list , return list with angle , midpoint & length for each vertice
(defun Get_Polly_Sizes (l)
  (mapcar '(lambda (a b) (list (angle a b) (mapcar '(lambda (x y) (/ (+ x y) 2)) a b)(distance a b)))
          l (append (cdr l) (list (car l)))))

; returns largest distance between point from a point list (p1 p2 p3...) -> (dist p2 p3)
; test : (setq lst (Get_Big_Polly (get_polly_points (car (entsel)))))
(defun get_big_polly (l)
  (car (vl-sort (mapcar '(lambda (a b) (cons (distance a b) (list a b)))
   l (append (cdr l) (list (car l)))) ''((a b)(> (car a)(car b))))))

; l = list with angle, midpoint & length for each vertex (get_polly_sizes (get_polly_points(car (entsel))))
; driehoek 0,10 / 30,30 / 40,10
; bv ((0.588003 (15.0 20.0 0.0) 36.0555) (5.17604 (35.0 20.0 0.0) 22.3607) (3.14159 (20.0 10.0 0.0) 40.0))
; zoek nu laagste mid point en meest linkse
; c = centerpoint of gravity '(x y z)
; vl = vertex list ((l1 p1 p2) (l2 p2 p3) (l3 p3 p1)...)
(defun get_squared ( l c / vl )
  ; get (unsorted) list ((vertex-length p1 p2) . . .)
  (setq vl (mapcar '(lambda (a b) (cons (distance a b) (list a b))) l (append (cdr l) (list (car l))))
        x- (apply 'min (mapcar 'cadr vl)) y- (apply 'min (mapcar 'caddr vl)))
  ; most left vertex in square will have smallest x and lowest will have smallest y
)


;;; Gile (setq lst (get_polly_points (car (entsel))))
(defun Get_Polly_Points (pl / pa pt lst)(vl-load-com)
  (setq	pa (if (vlax-curve-IsClosed pl)(vlax-curve-getEndParam pl)(+ (vlax-curve-getEndParam pl) 1)))
  (while (setq pt (vlax-curve-getPointAtParam pl (setq pa (- pa 1))))(setq lst (cons pt lst))))

; s = space , e = polly (ent or obj)
(defun Get_Polly_Center ( s e / o r c )
  (or (= (type e) 'VLA-OBJECT) (setq o (vlax-ename->vla-object e)))
  (setq r (vlax-invoke s 'addRegion (list o)) c (vlax-get (car r) 'Centroid))
  (vla-delete (car r))(trans c 1 (vlax-get o 'Normal)))

;checks if entity (polyline) contains an arc (no-arc (car (entsel)))
(defun no-arc (e) (zerop (apply '+ (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget e))))))

; sorts point list on length and removes the longest
; (Get_Triangle_Polly_Lengths (get_polly_points (car (entsel))))
(defun Get_Triangle_Polly_Lengths (l / r)
  (cdr (vl-sort (mapcar '(lambda (a b) (/ (distance a b) 1)) l (append (cdr l) (list (car l)))) '>)))

; (Get_Square_Polly_Lengths (get_polly_points (car (entsel))))
(defun Get_Square_Polly_Lengths (l / r)
  (cddr (mapcar '(lambda (a b) (/ (distance a b) 1)) l (append (cdr l) (list (car l))))))

;;;remove duplicates
(defun rdup (i / o) (vl-remove-if '(lambda (x) (cond ((vl-position x o) t) ((setq o (cons x o)) nil))) i))

;;; http://www.lee-mac.com/mathematicalfunctions.html#geomproj
;;; Project Point onto Line  -  Lee Mac - Projects pt onto the line defined by p1,p2
(defun LM:ProjectPointToLine ( pt p1 p2 / nm )
  (setq nm (mapcar '- p2 p1) p1 (trans p1 0 nm) pt (trans pt 0 nm))
  (trans (list (car p1) (cadr p1) (caddr pt)) nm 0)
)

; https://www.cadtutor.net/forum/topic/60652-lisp-minimum-bounding-box-for-rotated-attributeblock/

;; Minimum Bounding Box  -  Lee Mac
;; Returns the WCS coordinates describing the minimum bounding rectangle
;; surrounding all objects in a supplied selection set.
;; sel - [sel] selection set to process
;; tol - [rea] precision of calculation, 0 < tol < 1

(defun LM:minboundingbox ( sel tol / ang box bx1 bx2 cen idx lst obj rtn )
  (if (and sel (< 0.0 tol 1.0))
    (progn
      (repeat (setq idx (sslength sel))
        (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
        (if (and (vlax-method-applicable-p obj 'getboundingbox)
                 (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'a 'b)))))
          (setq lst (cons (vla-copy obj) lst))))
      (if lst
        (progn
          (setq box (LM:objlstboundingbox lst) tol (* tol pi)
                cen (apply 'mapcar (cons '(lambda ( a b ) (/ (+ a b) 2.0)) box))
                bx1 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box))) rtn (list 0.0 box) ang 0.0)
          (while (< (setq ang (+ ang tol)) pi)
            (foreach obj lst (vlax-invoke obj 'rotate cen tol))
            (setq box (LM:objlstboundingbox lst) bx2 (* (- (caadr box) (caar box)) (- (cadadr box) (cadar box))))
            (if (< bx2 bx1) (setq bx1 bx2 rtn (list ang box))))
          (foreach obj lst (vla-delete obj))
          (LM:rotatepoints (mapcar '(lambda ( a ) (mapcar '(lambda ( b ) (apply b (cdr rtn))) a))
                                   '((caar cadar) (caadr  cadar) (caadr cadadr) (caar  cadadr))) cen (- (car rtn)))
        )
      )
    )
  )
)

;; Object List Bounding Box  -  Lee Mac
;; Returns the lower-left and upper-right points of a rectangle bounding a list of objects

(defun LM:objlstboundingbox ( lst / llp ls1 ls2 urp )
  (foreach obj lst
    (vla-getboundingbox obj 'llp 'urp)
    (setq ls1 (cons (vlax-safearray->list llp) ls1) ls2 (cons (vlax-safearray->list urp) ls2)))
  (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list ls1 ls2))
)

;; Rotate Points  -  Lee Mac - Rotates a list of points about a supplied point by a given angle
(defun LM:rotatepoints ( lst bpt ang / mat vec )
  (setq mat (list (list (cos ang)(sin (- ang)) 0.0)(list (sin ang)(cos ang) 0.0) '(0.0 0.0 1.0)))
  (setq vec (mapcar '- bpt (mxv mat bpt)))(mapcar '(lambda ( x ) (mapcar '+ (mxv mat x) vec)) lst))

;; Matrix x Vector - Vladimir Nesterovsky - Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )  (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m))

; test if all angles from a polyline add up to 360 degrees (* pi 2). Sometimes polylines have 'broken' vertices so ang=0
; partially based on LM:GetInsideAngle - test : (square-p (get_polly_points (car (entsel))))
(defun square-p (l)
  (equal (rem (apply '+ (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
    (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
      (append (cddr l)(list (car l) (cadr l))))) pi) 0.0 0.1))


; test if all angles from a polyline add up to 180 degrees (pi). Fails when one of 3 vertices containa a bulge
; so additional bulge test required - test : (triangle-p (get_polly_points (car (entsel))))
(defun triangle-p (l)
  (equal pi (apply '+ (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
    (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
      (append (cddr l)(list (car l) (cadr l))))) 0.1))

; test if polyline has 90 degree angle - test : (90-p (get_polly_points (car (entsel))))
(defun 90-p (l)
  (vl-some (function (lambda (a)(equal a (/ pi 2) 0.01)))
    (mapcar '(lambda (x y z)((lambda (a)(min a (- (+ pi pi) a)))
      (rem (+ pi pi (- (angle y x)(angle y z))) (+ pi pi)))) l (append (cdr l) (list (car l)))
        (append (cddr l)(list (car l) (cadr l))))))


(defun place_table ( lst / total-area pt acm tbl col y calc-type-list fac row col area)
  (setq total-area 0 pt (getpoint "\nSelect point to place table : ") colums 5)
  (setq acm (vla-getinterfaceobject (vlax-get-acad-object) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
  ; makes a table with as many rows as length lst plus 3 (2 for the title and headers plus 1 for total)
  ; 2 columns, row height 5 and cell width 20
  (setq tbl (vla-AddTable spc (vlax-3d-point pt) (+ 3 (length lst)) colums 5 25)) 
  (vla-setcelltextheight tbl 0 0 2.5) ; title text height 2.5, to stand out
  (vla-put-colorindex acm 7)
  (repeat (setq row (vla-get-rows tbl))
    (setq row (1- row))
    (repeat (setq col (vla-get-columns tbl))
      (vla-setcelltextheight tbl row (setq col (1- col)) 2.5)
      (vla-setCellAlignment tbl row col 5) ; center text
      (vla-setcellcontentcolor tbl row col acm)
    )
  )
  
  (vla-setText tbl 0 0 "Areas") ; fill in title
  (vla-setText tbl 1 0 "Block") ; fill in headers
  (vla-setText tbl 1 1 "a")
  (vla-setText tbl 1 2 "b")
  (vla-setText tbl 1 3 "c")
  (vla-setText tbl 1 4 "Area")
  ;(setq row 2 calc-type-list '((1 . "")(2 . "0.5")(3 . "0.5")(4 . "0.66")))
  (setq row 2 calc-type-list '((1 . "")(2 . "1/2")(3 . "1/2")(4 . "2/3")))
  ; lst = ( ([polly-no] [(l1 l2)] [calc-type]) ...)
  (foreach item lst
    (vla-setText tbl row 0 (if ascii-mode (itol (car item))(itoa (car item)))) ; block no.
    (vla-setText tbl row 1 (rtos (caadr item) 2 2)) ; lenght 1
    (vla-setText tbl row 2 (rtos (if (cadadr item)(cadadr item)(caadr item)) 2 2)); length 2
    (vla-setText tbl row 3 (setq fac (cdr (assoc (last item) calc-type-list))))
    (if (eq fac "")
      (setq area (* (caadr item)(if (cadadr item)(cadadr item)(caadr item))))
      (setq area (* (atof fac) (caadr item)(if (cadadr item)(cadadr item)(caadr item)))))
    (vla-setText tbl row 4 (rtos area 2 2)) (setq total-area (+ total-area area))
    (setq row (1+ row))
  )

  ; still have to add row with total
  (vla-setText tbl row 0 "Total")(vla-setText tbl row 4 (rtos total-area 2 2))
  
  ; put the color (white)
  
 ;(vla-put-colorindex acm 7)
  (vla-put-regeneratetablesuppressed tbl :vlax-true)
 (repeat (setq row (vla-get-rows tbl))
  (setq row (1- row))(repeat (setq col (vla-get-columns tbl))))
 (vla-put-color tbl 7)

 (vla-put-regeneratetablesuppressed tbl :vlax-false)
  
  (vlax-release-object tbl)      
  (vlax-release-object spc)    
)
; (c:t4)

not sure if this is gonna work for you but just don't have enough time at this moment , too much other stuf to do right now. Fixed text height to 2.5 at different places but as Bigal said , with so many posts you're a big boy now so I'm sure you can change this if needed.

January 11, 2022

Hi rlx . Is to difficult for me to change it. All this yaers i learn some things about lisp but still need help. I am searching for a code to write analytic the area of multy close polyline (triagles or rectanfes ) like the example. The last code insert only dimensions and the area text. I have a lot of drawings with area analylic calculations.

E1 = 1/2 x 59.328 x 102.361 = 3036.410 sq.m
E2 = 1/2 x 16.672 x 85.953 = 716.521 sq.m
E3 = 1/2 x 73.395 x 97.338 = 3756.397 sq.m
E4 = 1/2 x 26.281 x 97.338 = 1279.042 sq.m
Total = 3036.410 + 716.521 + 3756.397 + 1279.042 = 8785.37 sq.m

Thanks

Sign In

auto area calculation table

Recommended Posts

wil3000

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

rlx

rlx

Posted Images

rlx

Zaidkhot

rlx

BIGAL

Guest

BIGAL

Guest

Guest

rlx

Guest

Join the conversation

rlx

rlx

Tutorials

Forums

Activity