wil3000 Posted September 1, 2021 Posted 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 Quote
rlx Posted September 1, 2021 Posted 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 Quote
Zaidkhot Posted November 11, 2021 Posted November 11, 2021 hey can you change the dimension precision to 3 digits in the excel table? Quote
rlx Posted November 11, 2021 Posted 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) Quote
BIGAL Posted November 12, 2021 Posted November 12, 2021 The quick in this case use a pattern to ensure. Quote
Guest Posted January 9, 2022 Posted 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 Quote
BIGAL Posted January 9, 2022 Posted January 9, 2022 Its about time you started to answer your own questions your not a new poster. Learn about lisp. Quote
Guest Posted January 9, 2022 Posted 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 Quote
rlx Posted January 11, 2022 Posted 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. Quote
Guest Posted January 11, 2022 Posted 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 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.