ectech Posted November 17, 2009 Share Posted November 17, 2009 Dear All, I need to select all polyline in drawing ( may be more than 50 polyline) then I need to calculate each area and make a mark on it( e.g. area1=xxx, area2...etc) then I need to export all calculated area to excel. how to make this lisp ? thanks. And I want to make sure that all the mark in order from left to right or from top to botom, is it difficult to do that ? Thanks ! Quote Link to comment Share on other sites More sharing options...
VVA Posted November 18, 2009 Share Posted November 18, 2009 Removed. See #5 Quote Link to comment Share on other sites More sharing options...
VVA Posted November 18, 2009 Share Posted November 18, 2009 Removed. See #5 Quote Link to comment Share on other sites More sharing options...
stevesfr Posted November 18, 2009 Share Posted November 18, 2009 If you have Command AreaPL marks polyline (use text) Command AreaXL exports its Excell (defun c:AreaPL (/ adoc ent pt *error* ed obj txt i) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y) (< (car (eea-centroid-solid-lw (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget x) ) ) (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget x) ) ) ) ) (car (eea-centroid-solid-lw (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget y) ) ) (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget y) ) ) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq pt (eea-centroid-solid-lw (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) ed) ) (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 42)) ed) ) ) ) ;;; (setq fld (strcat "Area" ;;; (itoa (setq i (1+ i))) ;;; "=" ;;; "%<\\AcObjProp Object(%<\\_ObjId " ;;; (vl-princ-to-string (vla-get-objectid obj)) ;;; ">%).Area \\f \"%lu2%pr2\">%" ;;; ) ;;; ) (setq fld (rtos (vla-get-area obj) 2 2)) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) [color=red] (cons 40 2.5) ;_Text height[/color] ) ;_ list ) ;_ entmakex ) (vl-cmdf "_updatefield" txt "") ) ) (vla-endundomark adoc) (princ) ) ;_ end of defun (defun C:AreaXL (/ ss file fd) (command "_regenall") (and (setq ss (ssget "_X" (list '(0 . "TEXT") '(8 . "PlAreaReport") (cons 410 (getvar "CTAB")) ) ) ) (setq file (strcat (getvar "TEMPPREFIX") "PlAreaReport.csv")) (setq FD (open file "w")) (foreach ent (acad_strlsort (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) (write-line (vl-string-subst ";" "=" ent) FD ) ) (or (close fd) t) (vva-xopen file) ) ) (defun vva-xopen (name / di na sh) ;; http://www.theswamp.org/index.php?topic=29548.0 ;;;Usage ;;;(setq my_file (vva-xopen "c:/test.txt")) ;;;(setq my_file (vva-xopen "c:/test.avi")) ;;;(setq my_file (vva-xopen "c:/test.3gp")) (and (setq name (findfile name)) (setq sh (vlax-create-object "Shell.Application")) (setq di (vlax-invoke sh 'Namespace (vl-filename-directory name))) (setq na (vlax-invoke di 'parsename (strcat (vl-filename-base name) (vl-filename-extension name) ) ) ) (vlax-invoke-method na 'invokeverbex "open") ) (vlax-release-object sh) na ) (defun eea-centroid-solid-lw (pl bl / A1) ;| ***************************************************************************************** by ElpanovEvgeniy ***************************************************************************************** Library function. Centroid (the center of weights) region, inside of a polyline, having arc segments pl - list point bl - list bulge Date of creation 2000 - 2005 years. Last edit 08.06.2009 ***************************************************************************************** (setq e (car (entsel "\n Select LWPOLYLINE ")) pl nil bl nil ) ;_ setq (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (eea-centroid-solid-lw pl bl) ***************************************************************************************** (defun c:c1 (/ e bl pl) (setq e (car (entsel "\n Select LWPOLYLINE "))) (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (entmakex (list '(0 . "point") '(62 . 1) (cons 10 (eea-centroid-solid-lw pl bl)) (assoc 210 (entget e)) ) ;_ list ) ;_ entmakex ) ;_ defun ***************************************************************************************** |; (setq a1 0) (mapcar (function /) (apply (function mapcar) (cons (function +) (mapcar (function (lambda (p1 p2 b / A BB C I S) (setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2 ) a1 (+ i a1) i (/ i 3) ) ;_ setq (if (zerop b) (mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2) (progn (setq c (distance p1 p2) bb (* b b) a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)) ) ) (* 8 bb) ) a1 (+ a a1) s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b)) ) ;_ setq (mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c))) ) ) p1 p2 (list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s) ) (list a a) ) ;_ mapcar ) ;_ progn ) ;_ if ) ;_ lambda ) ;_ function (cons (last pl) pl) pl (cons (last bl) bl) ) ;_ mapcar ) ;_ cons ) ;_ apply (list a1 a1) ) ;_ mapcar ) ;_ defun (princ "\nType AreaPL or AreaXL in command line") I get the following error when running either version: Command: areapl Select objects: 1 found Select objects: bad argument type: numberp: nil Command: What could be causing the error? Using Acad 8. Quote Link to comment Share on other sites More sharing options...
VVA Posted November 18, 2009 Share Posted November 18, 2009 Try it Command AreaPLT marks polyline (use text) Command AreaPLF marks polyline (use field). Need >= Acad 2006 Command AreaXL exports area to Excell (defun c:AreaPLT (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) ;;; (setq fld (strcat "Area" ;;; (itoa (setq i (1+ i))) ;;; "=" ;;; "%<\\AcObjProp Object(%<\\_ObjId " ;;; (vl-princ-to-string (vla-get-objectid obj)) ;;; ">%).Area \\f \"%lu2%pr2\">%" ;;; ) ;;; ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) ) ) (vla-endundomark adoc) (princ) ) ;_ end of defun (defun c:AreaPLF (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid obj)) ">%).Area \\f \"%lu2%pr2\">%" ) ) ;;; (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) (vl-cmdf "_updatefield" txt "") ) ) (vla-endundomark adoc) (princ) ) (defun C:AreaXL (/ ss file fd) (command "_regenall") (and (setq ss (ssget "_X" (list '(0 . "TEXT") '(8 . "PlAreaReport") (cons 410 (getvar "CTAB")) ) ) ) (setq file (strcat (getvar "TEMPPREFIX") "PlAreaReport.csv")) (setq FD (open file "w")) (foreach ent (acad_strlsort (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) (write-line (vl-string-subst ";" "=" ent) FD ) ) (or (close fd) t) (vva-xopen file) ) ) (defun vva-xopen (name / di na sh) ;; http://www.theswamp.org/index.php?topic=29548.0 ;;;Usage ;;;(setq my_file (vva-xopen "c:/test.txt")) ;;;(setq my_file (vva-xopen "c:/test.avi")) ;;;(setq my_file (vva-xopen "c:/test.3gp")) (and (setq name (findfile name)) (setq sh (vlax-create-object "Shell.Application")) (setq di (vlax-invoke sh 'Namespace (vl-filename-directory name))) (setq na (vlax-invoke di 'parsename (strcat (vl-filename-base name) (vl-filename-extension name) ) ) ) (vlax-invoke-method na 'invokeverbex "open") ) (vlax-release-object sh) na ) (defun pl:get-coors&bulge ( pl / ent_data tmp_ent blglist coors) (setq ent_data (entget pl)) (if (= (cdr(assoc 0 ent_data)) "LWPOLYLINE") (foreach lst ent_data (setq num (car lst)) (cond ((= num 10)(setq coors (cons (cdr lst) coors))) ((= num 42)(setq blglist (cons (cdr lst) blglist))) (t nil) ) ) (progn (setq tmp_ent pl) (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_ent (entnext tmp_ent))))))) (setq coors (cons (cdr (assoc 10 ent_data)) coors)) (setq blglist (cons (cdr (assoc 42 ent_data)) blglist)) );_while ) ) (list (reverse coors) (reverse blglist) ) ) (defun eea-centroid-solid-lw (pl bl / A1) ;| ***************************************************************************************** by ElpanovEvgeniy ***************************************************************************************** Library function. Centroid (the center of weights) region, inside of a polyline, having arc segments pl - list point bl - list bulge Date of creation 2000 - 2005 years. Last edit 08.06.2009 ***************************************************************************************** (setq e (car (entsel "\n Select LWPOLYLINE ")) pl nil bl nil ) ;_ setq (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (eea-centroid-solid-lw pl bl) ***************************************************************************************** (defun c:c1 (/ e bl pl) (setq e (car (entsel "\n Select LWPOLYLINE "))) (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (entmakex (list '(0 . "point") '(62 . 1) (cons 10 (eea-centroid-solid-lw pl bl)) (assoc 210 (entget e)) ) ;_ list ) ;_ entmakex ) ;_ defun ***************************************************************************************** |; (setq a1 0) (mapcar (function /) (apply (function mapcar) (cons (function +) (mapcar (function (lambda (p1 p2 b / A BB C I S) (setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2 ) a1 (+ i a1) i (/ i 3) ) ;_ setq (if (zerop b) (mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2) (progn (setq c (distance p1 p2) bb (* b b) a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)) ) ) (* 8 bb) ) a1 (+ a a1) s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b)) ) ;_ setq (mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c))) ) ) p1 p2 (list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s) ) (list a a) ) ;_ mapcar ) ;_ progn ) ;_ if ) ;_ lambda ) ;_ function (cons (last pl) pl) pl (cons (last bl) bl) ) ;_ mapcar ) ;_ cons ) ;_ apply (list a1 a1) ) ;_ mapcar ) ;_ defun (princ "\nType AreaPLT AreaPLF or AreaXL in command line") Quote Link to comment Share on other sites More sharing options...
stevesfr Posted November 18, 2009 Share Posted November 18, 2009 Try itCommand AreaPLT marks polyline (use text) Command AreaPLF marks polyline (use field). Need >= Acad 2006 Command AreaXL exports its Excell (defun c:AreaPLT (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) ;;; (setq fld (strcat "Area" ;;; (itoa (setq i (1+ i))) ;;; "=" ;;; "%<\\AcObjProp Object(%<\\_ObjId " ;;; (vl-princ-to-string (vla-get-objectid obj)) ;;; ">%).Area \\f \"%lu2%pr2\">%" ;;; ) ;;; ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) ) ) (vla-endundomark adoc) (princ) ) ;_ end of defun (defun c:AreaPLF (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid obj)) ">%).Area \\f \"%lu2%pr2\">%" ) ) ;;; (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) (vl-cmdf "_updatefield" txt "") ) ) (vla-endundomark adoc) (princ) ) (defun C:AreaXL (/ ss file fd) (command "_regenall") (and (setq ss (ssget "_X" (list '(0 . "TEXT") '(8 . "PlAreaReport") (cons 410 (getvar "CTAB")) ) ) ) (setq file (strcat (getvar "TEMPPREFIX") "PlAreaReport.csv")) (setq FD (open file "w")) (foreach ent (acad_strlsort (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) (write-line (vl-string-subst ";" "=" ent) FD ) ) (or (close fd) t) (vva-xopen file) ) ) (defun vva-xopen (name / di na sh) ;; http://www.theswamp.org/index.php?topic=29548.0 ;;;Usage ;;;(setq my_file (vva-xopen "c:/test.txt")) ;;;(setq my_file (vva-xopen "c:/test.avi")) ;;;(setq my_file (vva-xopen "c:/test.3gp")) (and (setq name (findfile name)) (setq sh (vlax-create-object "Shell.Application")) (setq di (vlax-invoke sh 'Namespace (vl-filename-directory name))) (setq na (vlax-invoke di 'parsename (strcat (vl-filename-base name) (vl-filename-extension name) ) ) ) (vlax-invoke-method na 'invokeverbex "open") ) (vlax-release-object sh) na ) (defun pl:get-coors&bulge ( pl / ent_data tmp_ent blglist coors) (setq ent_data (entget pl)) (if (= (cdr(assoc 0 ent_data)) "LWPOLYLINE") (foreach lst ent_data (setq num (car lst)) (cond ((= num 10)(setq coors (cons (cdr lst) coors))) ((= num 42)(setq blglist (cons (cdr lst) blglist))) (t nil) ) ) (progn (setq tmp_ent pl) (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_ent (entnext tmp_ent))))))) (setq coors (cons (cdr (assoc 10 ent_data)) coors)) (setq blglist (cons (cdr (assoc 42 ent_data)) blglist)) );_while ) ) (list (reverse coors) (reverse blglist) ) ) (defun eea-centroid-solid-lw (pl bl / A1) ;| ***************************************************************************************** by ElpanovEvgeniy ***************************************************************************************** Library function. Centroid (the center of weights) region, inside of a polyline, having arc segments pl - list point bl - list bulge Date of creation 2000 - 2005 years. Last edit 08.06.2009 ***************************************************************************************** (setq e (car (entsel "\n Select LWPOLYLINE ")) pl nil bl nil ) ;_ setq (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (eea-centroid-solid-lw pl bl) ***************************************************************************************** (defun c:c1 (/ e bl pl) (setq e (car (entsel "\n Select LWPOLYLINE "))) (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (entmakex (list '(0 . "point") '(62 . 1) (cons 10 (eea-centroid-solid-lw pl bl)) (assoc 210 (entget e)) ) ;_ list ) ;_ entmakex ) ;_ defun ***************************************************************************************** |; (setq a1 0) (mapcar (function /) (apply (function mapcar) (cons (function +) (mapcar (function (lambda (p1 p2 b / A BB C I S) (setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2 ) a1 (+ i a1) i (/ i 3) ) ;_ setq (if (zerop b) (mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2) (progn (setq c (distance p1 p2) bb (* b b) a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)) ) ) (* 8 bb) ) a1 (+ a a1) s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b)) ) ;_ setq (mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c))) ) ) p1 p2 (list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s) ) (list a a) ) ;_ mapcar ) ;_ progn ) ;_ if ) ;_ lambda ) ;_ function (cons (last pl) pl) pl (cons (last bl) bl) ) ;_ mapcar ) ;_ cons ) ;_ apply (list a1 a1) ) ;_ mapcar ) ;_ defun (princ "\nType AreaPLT AreaPLF or AreaXL in command line") VVA: perfect, thanks for great code ! Quote Link to comment Share on other sites More sharing options...
viviancarvalho Posted November 18, 2009 Share Posted November 18, 2009 You may even check this out Its written by Fixo. All thanks to him AreasToXL_V5.LSP Quote Link to comment Share on other sites More sharing options...
ectech Posted November 20, 2009 Author Share Posted November 20, 2009 thanks ! is it possible to check any overlap polyline within the drawing, because if 2 overlap polyline in the same location, it will affect the result. And this lisp need select the polyline one by one, can you make it select all polyline automatically ? Thanks again VVA viviancarvalho and stevesfr. Quote Link to comment Share on other sites More sharing options...
bbb120 Posted December 20, 2009 Share Posted December 20, 2009 only for polyline? Quote Link to comment Share on other sites More sharing options...
bbb120 Posted December 20, 2009 Share Posted December 20, 2009 Try itCommand AreaPLT marks polyline (use text) Command AreaPLF marks polyline (use field). Need >= Acad 2006 Command AreaXL exports area to Excell (defun c:AreaPLT (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) ;;; (setq fld (strcat "Area" ;;; (itoa (setq i (1+ i))) ;;; "=" ;;; "%<\\AcObjProp Object(%<\\_ObjId " ;;; (vl-princ-to-string (vla-get-objectid obj)) ;;; ">%).Area \\f \"%lu2%pr2\">%" ;;; ) ;;; ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) ) ) (vla-endundomark adoc) (princ) ) ;_ end of defun (defun c:AreaPLF (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid obj)) ">%).Area \\f \"%lu2%pr2\">%" ) ) ;;; (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) (vl-cmdf "_updatefield" txt "") ) ) (vla-endundomark adoc) (princ) ) (defun C:AreaXL (/ ss file fd) (command "_regenall") (and (setq ss (ssget "_X" (list '(0 . "TEXT") '(8 . "PlAreaReport") (cons 410 (getvar "CTAB")) ) ) ) (setq file (strcat (getvar "TEMPPREFIX") "PlAreaReport.csv")) (setq FD (open file "w")) (foreach ent (acad_strlsort (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) (write-line (vl-string-subst ";" "=" ent) FD ) ) (or (close fd) t) (vva-xopen file) ) ) (defun vva-xopen (name / di na sh) ;; http://www.theswamp.org/index.php?topic=29548.0 ;;;Usage ;;;(setq my_file (vva-xopen "c:/test.txt")) ;;;(setq my_file (vva-xopen "c:/test.avi")) ;;;(setq my_file (vva-xopen "c:/test.3gp")) (and (setq name (findfile name)) (setq sh (vlax-create-object "Shell.Application")) (setq di (vlax-invoke sh 'Namespace (vl-filename-directory name))) (setq na (vlax-invoke di 'parsename (strcat (vl-filename-base name) (vl-filename-extension name) ) ) ) (vlax-invoke-method na 'invokeverbex "open") ) (vlax-release-object sh) na ) (defun pl:get-coors&bulge ( pl / ent_data tmp_ent blglist coors) (setq ent_data (entget pl)) (if (= (cdr(assoc 0 ent_data)) "LWPOLYLINE") (foreach lst ent_data (setq num (car lst)) (cond ((= num 10)(setq coors (cons (cdr lst) coors))) ((= num 42)(setq blglist (cons (cdr lst) blglist))) (t nil) ) ) (progn (setq tmp_ent pl) (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_ent (entnext tmp_ent))))))) (setq coors (cons (cdr (assoc 10 ent_data)) coors)) (setq blglist (cons (cdr (assoc 42 ent_data)) blglist)) );_while ) ) (list (reverse coors) (reverse blglist) ) ) (defun eea-centroid-solid-lw (pl bl / A1) ;| ***************************************************************************************** by ElpanovEvgeniy ***************************************************************************************** Library function. Centroid (the center of weights) region, inside of a polyline, having arc segments pl - list point bl - list bulge Date of creation 2000 - 2005 years. Last edit 08.06.2009 ***************************************************************************************** (setq e (car (entsel "\n Select LWPOLYLINE ")) pl nil bl nil ) ;_ setq (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (eea-centroid-solid-lw pl bl) ***************************************************************************************** (defun c:c1 (/ e bl pl) (setq e (car (entsel "\n Select LWPOLYLINE "))) (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (entmakex (list '(0 . "point") '(62 . 1) (cons 10 (eea-centroid-solid-lw pl bl)) (assoc 210 (entget e)) ) ;_ list ) ;_ entmakex ) ;_ defun ***************************************************************************************** |; (setq a1 0) (mapcar (function /) (apply (function mapcar) (cons (function +) (mapcar (function (lambda (p1 p2 b / A BB C I S) (setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2 ) a1 (+ i a1) i (/ i 3) ) ;_ setq (if (zerop b) (mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2) (progn (setq c (distance p1 p2) bb (* b b) a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)) ) ) (* 8 bb) ) a1 (+ a a1) s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b)) ) ;_ setq (mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c))) ) ) p1 p2 (list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s) ) (list a a) ) ;_ mapcar ) ;_ progn ) ;_ if ) ;_ lambda ) ;_ function (cons (last pl) pl) pl (cons (last bl) bl) ) ;_ mapcar ) ;_ cons ) ;_ apply (list a1 a1) ) ;_ mapcar ) ;_ defun (princ "\nType AreaPLT AreaPLF or AreaXL in command line") only for polyline ?I need a similar LISP file ,please view the thread Calculate Area by picking internal point [/color][/size][/font][/i][/b]>,can you make Lee Mac's code(#16) work better ?I think you can according your code posted here.please help me.Thank you in advance .please post your modified code at the end of this thread. Quote Link to comment Share on other sites More sharing options...
bbb120 Posted December 20, 2009 Share Posted December 20, 2009 Try itCommand AreaPLT marks polyline (use text) Command AreaPLF marks polyline (use field). Need >= Acad 2006 Command AreaXL exports area to Excell (defun c:AreaPLT (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) ;;; (setq fld (strcat "Area" ;;; (itoa (setq i (1+ i))) ;;; "=" ;;; "%<\\AcObjProp Object(%<\\_ObjId " ;;; (vl-princ-to-string (vla-get-objectid obj)) ;;; ">%).Area \\f \"%lu2%pr2\">%" ;;; ) ;;; ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) ) ) (vla-endundomark adoc) (princ) ) ;_ end of defun (defun c:AreaPLF (/ adoc ent pt *error* ed obj txt i tmp) (defun *error* (msg) (vla-endundomark adoc) (princ msg) (princ) ) ;_ end of defun (vl-load-com) (setq adoc (vla-get-activedocument (vlax-get-acad-object))) (vla-startundomark adoc) (and (setq ss (ssget "_:L" '((0 . "*POLYLINE") (70 . 1)))) (setq i 0) (foreach ent (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) '(lambda (x y / tmp1 tmp2) (setq tmp1 (pl:get-coors&bulge x) tmp2 (pl:get-coors&bulge y) ) (< (car (eea-centroid-solid-lw (car tmp1) (cadr tmp1) ) ) (car (eea-centroid-solid-lw (car tmp2) (cadr tmp2) ) ) ) ) ) (setq ed (entget ent) obj (vlax-ename->vla-object ent) ) (setq tmp (pl:get-coors&bulge ent)) (setq pt (eea-centroid-solid-lw (car tmp) (cadr tmp) ) ) (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" "%<\\AcObjProp Object(%<\\_ObjId " (vl-princ-to-string (vla-get-objectid obj)) ">%).Area \\f \"%lu2%pr2\">%" ) ) ;;; (setq fld (strcat "Area" (itoa (setq i (1+ i))) "=" (rtos (vla-get-area obj) 2 2))) (setq txt (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 100 "AcDbText") (cons 72 0) (cons 1 fld) ;(cons 7 style) ;_Style (cons 8 "PlAreaReport") ;_Layer (cons 10 pt) (cons 11 pt) (cons 40 2.5) ;_Text height ) ;_ list ) ;_ entmakex ) (vl-cmdf "_updatefield" txt "") ) ) (vla-endundomark adoc) (princ) ) (defun C:AreaXL (/ ss file fd) (command "_regenall") (and (setq ss (ssget "_X" (list '(0 . "TEXT") '(8 . "PlAreaReport") (cons 410 (getvar "CTAB")) ) ) ) (setq file (strcat (getvar "TEMPPREFIX") "PlAreaReport.csv")) (setq FD (open file "w")) (foreach ent (acad_strlsort (mapcar '(lambda (x) (cdr (assoc 1 (entget x)))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) ) ) (write-line (vl-string-subst ";" "=" ent) FD ) ) (or (close fd) t) (vva-xopen file) ) ) (defun vva-xopen (name / di na sh) ;; http://www.theswamp.org/index.php?topic=29548.0 ;;;Usage ;;;(setq my_file (vva-xopen "c:/test.txt")) ;;;(setq my_file (vva-xopen "c:/test.avi")) ;;;(setq my_file (vva-xopen "c:/test.3gp")) (and (setq name (findfile name)) (setq sh (vlax-create-object "Shell.Application")) (setq di (vlax-invoke sh 'Namespace (vl-filename-directory name))) (setq na (vlax-invoke di 'parsename (strcat (vl-filename-base name) (vl-filename-extension name) ) ) ) (vlax-invoke-method na 'invokeverbex "open") ) (vlax-release-object sh) na ) (defun pl:get-coors&bulge ( pl / ent_data tmp_ent blglist coors) (setq ent_data (entget pl)) (if (= (cdr(assoc 0 ent_data)) "LWPOLYLINE") (foreach lst ent_data (setq num (car lst)) (cond ((= num 10)(setq coors (cons (cdr lst) coors))) ((= num 42)(setq blglist (cons (cdr lst) blglist))) (t nil) ) ) (progn (setq tmp_ent pl) (while (/= "SEQEND" (cdr(assoc 0 (setq ent_data (entget(setq tmp_ent (entnext tmp_ent))))))) (setq coors (cons (cdr (assoc 10 ent_data)) coors)) (setq blglist (cons (cdr (assoc 42 ent_data)) blglist)) );_while ) ) (list (reverse coors) (reverse blglist) ) ) (defun eea-centroid-solid-lw (pl bl / A1) ;| ***************************************************************************************** by ElpanovEvgeniy ***************************************************************************************** Library function. Centroid (the center of weights) region, inside of a polyline, having arc segments pl - list point bl - list bulge Date of creation 2000 - 2005 years. Last edit 08.06.2009 ***************************************************************************************** (setq e (car (entsel "\n Select LWPOLYLINE ")) pl nil bl nil ) ;_ setq (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (eea-centroid-solid-lw pl bl) ***************************************************************************************** (defun c:c1 (/ e bl pl) (setq e (car (entsel "\n Select LWPOLYLINE "))) (foreach a (reverse (entget e)) (cond ((= (car a) 10) (setq pl (cons (cdr a) pl))) ((= (car a) 42) (setq bl (cons (cdr a) bl))) ) ;_ cond ) ;_ foreach (entmakex (list '(0 . "point") '(62 . 1) (cons 10 (eea-centroid-solid-lw pl bl)) (assoc 210 (entget e)) ) ;_ list ) ;_ entmakex ) ;_ defun ***************************************************************************************** |; (setq a1 0) (mapcar (function /) (apply (function mapcar) (cons (function +) (mapcar (function (lambda (p1 p2 b / A BB C I S) (setq i (/ (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1))) 2 ) a1 (+ i a1) i (/ i 3) ) ;_ setq (if (zerop b) (mapcar (function (lambda (a b) (* (+ a b) i))) p1 p2) (progn (setq c (distance p1 p2) bb (* b b) a (/ (* c c (- (* (atan b) (1+ bb) (1+ bb)) (* b (- 1 bb)) ) ) (* 8 bb) ) a1 (+ a a1) s (/ (- (* b c c) (* 3 a (- 1 bb))) (* 12 a b)) ) ;_ setq (mapcar (function (lambda (a b c d) (+ (* (+ a b) i) (* d (+ (/ (+ a b) 2) c))) ) ) p1 p2 (list (* (- (cadr p2) (cadr p1)) s) (* (- (car p2) (car p1)) -1 s) ) (list a a) ) ;_ mapcar ) ;_ progn ) ;_ if ) ;_ lambda ) ;_ function (cons (last pl) pl) pl (cons (last bl) bl) ) ;_ mapcar ) ;_ cons ) ;_ apply (list a1 a1) ) ;_ mapcar ) ;_ defun (princ "\nType AreaPLT AreaPLF or AreaXL in command line") I need to make marks on the area which have been measured ,but Lee Mac's code does not have such a function ,your code can ,but your code only for polyline ,I think you can make your code work better base on Lee Mac's code. your code of EcoorE.lsp works perfect on my machine.I like it very much. Quote Link to comment Share on other sites More sharing options...
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.