auto area calculation table

[wil3000]

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

 

[rlx]

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

[Zaidkhot]

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

 

[rlx]

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)

 

 

 

 

[BIGAL]

The quick in this case use a pattern to ensure. 

[Guest]

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

[BIGAL]

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

[Guest]

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

[Guest]

any option?

[rlx]

; 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.

 

 

[Guest]

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