Guest ego Posted August 21, 2018 Posted August 21, 2018 (edited) This lisp has the ability to write the area of a multi-selected object using the reactor. However it does not work in the 2018 CAD version. What's the solution? ;;=================== (defun c:test( / ss i sum lst rlst ss mm obj2 area txt react space pt *error* )(vl-load-com) ;;===========================================;; ;; Sub-02 Function ;; ;;===========================================;; (defun PTE:text-style ( na siz wid f1 f2 ) (if (not (tblsearch "STYLE" na)) (entmakex (list (cons 0 "STYLE") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbTextStyleTableRecord") (cons 2 na) (cons 70 0) (cons 40 siz) (cons 41 wid) (cons 50 0.0) (cons 71 0) (cons 42 siz) (cons 3 f1) (cons 4 f2) ) ) ) ) ;;===========================================;; ;; Sub-03 Function ;; ;;===========================================;; (defun PTE:layer( la col lty / layer ) (while (not(tblsearch "layer" la)) (setq Layer (vla-add (vla-get-Layers (vla-get-activedocument(vlax-get-acad-object))) la ) ) (vla-put-Color Layer col) (vla-put-Linetype Layer lty) ) ) ;;===========================================;; ;; Sub-04 Function ;; ;;===========================================;; (defun PTE:ss->obj ( ss / i re ) (if ss (repeat (setq i (sslength ss)) (setq re (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) re)) ) ) ) ;;===========================================;; ;; Sub-06 Function ;; ;;===========================================;; (defun PTE:Text (pt str ag siz) (setq obj (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) str (vlax-3d-point (trans pt 1 0)) siz)) (vla-put-Alignment obj ag) ;10 middle 9 left (vla-put-TextAlignmentPoint obj (vlax-3d-point pt)) obj ) ;;===========================================;; ;; Sub-07 Function ;; ;;===========================================;; (defun PTE:temp110919 ( space pt title data __siz / _itemp i j tbstyle ) (defun _itemp ( collection item ) (if (not (vl-catch-all-error-p (setq item (vl-catch-all-apply 'vla-item (list collection item)) ) ) ) item ) ) (setq i 0 j 0) (vla-setTextHeight (setq tbstyle (_itemp (_itemp (vla-get-Dictionaries (vla-get-ActiveDocument (vlax-get-acad-object)) ) "ACAD_TABLESTYLE" ) (getvar 'CTABLESTYLE) ) ) acDataRow __siz ) (vla-setTextHeight tbstyle acHeaderRow __siz) (vla-setTextHeight tbstyle AcTitleRow __siz) ( (lambda ( table ) (vla-put-StyleName table (getvar 'CTABLESTYLE)) (vla-SetText table 0 0 title) ( (lambda ( row ) (mapcar (function (lambda ( rowitem ) (setq row (1+ row)) (setq i (1+ i)) ( (lambda ( column ) (mapcar (function (lambda ( item ) (if (= i (length data)) (setq item (strcat "{\\Fromans|c0;\\C30;" item "}")) (setq item (strcat "{\\Fromans|c0;\\C2;" item "}")) ) (vla-SetText table row (setq column (1+ column)) item) (vla-setcellalignment table row column 5) ` ) ) rowitem ) ) -1 ) ) ) data ) ) 0 ) table ) ( (lambda ( textheight ) (setq aa textheight) (vla-AddTable space (vlax-3D-point pt) (1+ (length data)) (length (car data)) (* 2 textheight) (* textheight (apply 'max (cons (/ (strlen title) (length (car data))) (mapcar 'strlen (apply 'append data)) ) ) ) ) ) (vla-getTextHeight tbstyle acDataRow) ) ) ) ;;===========================================;; ;; Sub-08 Function ;; ;;===========================================;; (defun PTE:start( variable-list / ) (setq *list* variable-list) (setq *start* (mapcar 'getvar *list*)) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object))) ) (vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object))) ) ;;===========================================;; ;; Sub-09 Function ;; ;;===========================================;; (defun PTE:end nil (if (and *list* *start*) (mapcar 'setvar *list* *start*)) (setq *list* nil *start* nil *error* nil) (vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object))) ) ;;===================================================;; ;; M A I N - function ;; ;;===================================================;; (defun *error* (s) (PTE:end)(princ)) (PTE:start '("dimzin")) (PTE:layer "2" 2 "continuous") (PTE:text-style "PTE-text" 0 1 "ROMANS.SHX" "GHS.SHX") (setvar 'cmdecho 0) (setvar 'dimzin 0) (setq i 0 sum 0. lst '() rlst '() ss (PTE:ss->obj(ssget '((0 . "LWPOLYLINE,CIRCLE")))) ) (setq __siz (cond ( (getreal (strcat "\n Enter text size. <" (rtos (setq __siz (cond ( __siz ) ( 3. )) ) 2 1 ) ">: " ) ) ) ( __siz ) ) ) (setq __zin (cond ( (getint (strcat "\n Enter decimal point factor. <" (itoa (setq __zin (cond ( __zin ) ( 2 )) ) ) ">: " ) ) ) ( __zin ) ) ) (foreach obj ss (setq mm (PTE:MinMax obj) obj2 obj area (/ (vla-get-area obj) 1000000) sum (+ area sum) ) (setq txt (PTE:Text (mapcar '/ (mapcar '+ (car mm) (cadr mm)) (list 2 2)) (strcat (itoa (setq i (+ 1 i))) "-" (rtos area 2 __zin)) 10 __siz ) ) (vla-put-layer txt "2") (vla-put-StyleName txt "PTE-text") (setq react (vlr-pers (vlr-object-reactor (list obj2) (list txt i) '( (:vlr-modified . PTE:area-reactor-m) (:vlr-erased . PTE:area-reactor-e) ) ) ) ) (setq rlst (append rlst (list react))) (setq lst (append lst (list(list (itoa i) (rtos area 2 __zin))))) ) (if (vlax-method-applicable-p (setq space (vlax-get-property (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace) ) ) 'AddTable ) (progn (setq lst (append lst (list (list "ToTal" (rtos sum 2 __zin))))) (setq tobj (PTE:temp110919 space (setq pt(getpoint "\nPick the point for table")) "{\\Fromans|c0;\\C3;Area Table}" lst __siz ) ) (mapcar '(lambda (re) (vlr-data-set re (append (vlr-data re) (list tobj __zin)) ) ) rlst ) ) (princ "\n** This cad ver. don't service table. **") ) (PTE:end)(princ) ) ;;===========================================;; ;; CallBack Func. - 01 ;; ;;===========================================;; (defun PTE:area-table-arrange ( reactor area zin / table sum i ) (defun PTE:Mtext ( txt / len1 len2 ) (while (and (setq len1 (vl-string-search "\;" txt)) (setq len2 (vl-string-search "\\" txt)) ) (setq len1 (1+ len1) len2 (1+ len2) txt (vl-string-subst "" (substr txt len2 (1+ (- len1 len2))) txt) ) ) (while (and (setq len1 (vl-string-search "{" txt)) (setq len2 (vl-string-search "}" txt)) ) (setq txt (vl-string-subst "" "{" txt) txt (vl-string-subst "" "}" txt) ) ) txt ) ;;;__ (setq table (caddr(vlr-data reactor)) sum 0 i 0 ) (if (not(vlax-erased-p table)) (progn (vla-settext table (itoa(cadr(vlr-data reactor))) 1 (strcat "{\\Fromans|c0;\\C2;" area "}")) (repeat (- (vla-get-rows table) 2) (setq sum (+ sum (atof(PTE:Mtext(vla-gettext table (setq i (+ 1 i)) 1))))) ) (vla-settext table (- (vla-get-rows table) 1) 1 (strcat "{\\Fromans|c0;\\C30;" (rtos sum 2 zin) "}")) ) ) ) ;;===========================================;; ;; CallBack Func. - 02 ;; ;;===========================================;; (defun PTE:area-reactor-m ( owner reactor param / mm area txt ) (if (not(vlax-erased-p owner)) (progn (setq mm (PTE:MinMax owner) zin (cadddr(vlr-data reactor)) area (rtos ( / (vla-get-area owner) 1000000) 2 zin) ) (if (not(vlax-erased-p (setq txt(car(vlr-data reactor))))) (vla-put-textstring txt (strcat (itoa(cadr (vlr-data reactor))) "-" area)) ) (PTE:area-table-arrange reactor area zin) ) )(princ) ) ; (vla-put-TextAlignmentPoint ; (car(vlr-data reactor)) ; (vlax-make-variant ; (vlax-safearray-fill ; (vlax-make-safearray vlax-vbDouble '(0 . 2)) ; (mapcar '/ (mapcar '+ (car mm) (cadr mm)) (list 2 2 2)) ; ) ; ) ; ) ;;===========================================;; ;; CallBack Func. - 03 ;; ;;===========================================;; (defun PTE:area-reactor-e ( owner reactor param / ) (setq zin (cadddr(vlr-data reactor))) (PTE:area-table-arrange reactor "-" zin) (vlr-remove reactor) (princ) ) ;;===========================================;; ;; Sub-05 Function ;; ;;===========================================;; (defun PTE:MinMax ( ent / mi ma ylst xlst ans ) (cond ((= 'ENAME (type ent)) (vla-getboundingbox (vlax-ename->vla-object ent) 'mi 'ma) (setq ans(list (vlax-safearray->list mi) (vlax-safearray->list ma))) ) ((= 'VLA-OBJECT (type ent)) (vla-getboundingbox ent 'mi 'ma) (setq ans(list (vlax-safearray->list mi) (vlax-safearray->list ma))) ) ((= 'PICKSET (type ent)) (setq xlst '() ylst '() ) (mapcar '(lambda ( ename / mi ma ) (vla-getboundingbox (vlax-ename->vla-object ename) 'mi 'ma) (setq mi (vlax-safearray->list mi) ma (vlax-safearray->list ma) xlst (vl-sort (append xlst (list(car mi)) (list(car ma))) '<) ylst (vl-sort (append ylst (list(cadr mi)) (list(cadr ma))) '<) ) ) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ent))) ) (setq ans(list (list (car xlst) (car ylst)) (list (last xlst) (last ylst)))) ) ) ans ) Edited August 21, 2018 by CADTutor Putting code in code block Quote
CADTutor Posted August 21, 2018 Posted August 21, 2018 Hi Guest ego, you will need to create a user account if you want to continue posting in this topic. Quote
marko_ribar Posted August 21, 2018 Posted August 21, 2018 It works on my A2018... Although I modified it a little... I think the problem was in (vla-get-area) function - I replaced it with (vlax-curve-getarea)... :) (defun c:PTE ( / PTE:text-style PTE:layer PTE:ss->obj PTE:MinMax PTE:Text PTE:temp110919 PTE:start PTE:end *error* ss i sum lst rlst ss mm obj2 area txt react space pt ) (vl-load-com) ;;===========================================;; ;; Sub-02 Function ;; ;;===========================================;; (defun PTE:text-style ( na siz wid f1 f2 ) (if (not (tblsearch "STYLE" na)) (entmakex (list (cons 0 "STYLE") (cons 100 "AcDbSymbolTableRecord") (cons 100 "AcDbTextStyleTableRecord") (cons 2 na) (cons 70 0) (cons 40 siz) (cons 41 wid) (cons 50 0.0) (cons 71 0) (cons 42 siz) (cons 3 f1) (cons 4 f2) ) ) ) ) ;;===========================================;; ;; Sub-03 Function ;; ;;===========================================;; (defun PTE:layer ( la col lty / layer ) (while (not (tblsearch "layer" la)) (setq layer (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) la ) ) (vla-put-color layer col) (vla-put-linetype layer lty) ) ) ;;===========================================;; ;; Sub-04 Function ;; ;;===========================================;; (defun PTE:ss->obj ( ss / i re ) (if ss (repeat (setq i (sslength ss)) (setq re (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) re)) ) ) ) ;;===========================================;; ;; Sub-05 Function ;; ;;===========================================;; (defun PTE:MinMax ( ent / mi ma ylst xlst ans ) (cond ((= 'ENAME (type ent)) (vla-getboundingbox (vlax-ename->vla-object ent) 'mi 'ma) (setq ans (list (vlax-safearray->list mi) (vlax-safearray->list ma))) ) ((= 'VLA-OBJECT (type ent)) (vla-getboundingbox ent 'mi 'ma) (setq ans (list (vlax-safearray->list mi) (vlax-safearray->list ma))) ) ((= 'PICKSET (type ent)) (setq xlst '() ylst '() ) (mapcar '(lambda ( ename / mi ma ) (vla-getboundingbox (vlax-ename->vla-object ename) 'mi 'ma) (setq mi (vlax-safearray->list mi) ma (vlax-safearray->list ma) xlst (vl-sort (append xlst (list (car mi)) (list (car ma))) '<) ylst (vl-sort (append ylst (list (cadr mi)) (list (cadr ma))) '<) ) ) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ent))) ) (setq ans (list (list (car xlst) (car ylst)) (list (last xlst) (last ylst)))) ) ) ans ) ;;===========================================;; ;; Sub-06 Function ;; ;;===========================================;; (defun PTE:Text ( pt str ag siz ) (setq obj (vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) str (vlax-3d-point (trans pt 1 0)) siz)) (vla-put-alignment obj ag) ;10 middle 9 left (vla-put-textalignmentpoint obj (vlax-3d-point pt)) obj ) ;;===========================================;; ;; Sub-07 Function ;; ;;===========================================;; (defun PTE:temp110919 ( space pt title data __siz / _itemp i j tbstyle ) (defun _itemp ( collection item ) (if (not (vl-catch-all-error-p (setq item (vl-catch-all-apply 'vla-item (list collection item)) ) ) ) item ) ) (setq i 0 j 0) (vla-settextheight (setq tbstyle (_itemp (_itemp (vla-get-dictionaries (vla-get-activedocument (vlax-get-acad-object)) ) "ACAD_TABLESTYLE" ) (getvar 'CTABLESTYLE) ) ) acDataRow __siz ) (vla-settextheight tbstyle acHeaderRow __siz) (vla-settextheight tbstyle AcTitleRow __siz) ( (lambda ( table ) (vla-put-stylename table (getvar 'CTABLESTYLE)) (vla-settext table 0 0 title) ( (lambda ( row ) (mapcar (function (lambda ( rowitem ) (setq row (1+ row)) (setq i (1+ i)) ( (lambda ( column ) (mapcar (function (lambda ( item ) (if (= i (length data)) (setq item (strcat "{\\Fromans|c0;\\C30;" item "}")) (setq item (strcat "{\\Fromans|c0;\\C2;" item "}")) ) (vla-settext table row (setq column (1+ column)) item) (vla-setcellalignment table row column 5) ` ) ) rowitem ) ) -1 ) ) ) data ) ) 0 ) table ) ( (lambda ( textheight ) (setq aa textheight) (vla-addtable space (vlax-3d-point pt) (1+ (length data)) (length (car data)) (* 2 textheight) (* textheight (apply 'max (cons (/ (strlen title) (length (car data))) (mapcar 'strlen (apply 'append data)) ) ) ) ) ) (vla-gettextheight tbstyle acDataRow) ) ) ) ;;===========================================;; ;; Sub-08 Function ;; ;;===========================================;; (defun PTE:start ( variable-list / ) (setq *list* variable-list) (setq *start* (mapcar 'getvar *list*)) (if (= 8 (logand 8 (getvar 'UNDOCTL))) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) ) (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) ) ;;===========================================;; ;; Sub-09 Function ;; ;;===========================================;; (defun PTE:end nil (if (and *list* *start*) (mapcar 'setvar *list* *start*)) (setq *list* nil *start* nil) (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) ) ;;===================================================;; ;; M A I N - function ;; ;;===================================================;; (defun *error* ( s ) (PTE:end) (princ)) (PTE:start '("dimzin")) (PTE:layer "2" 2 "continuous") (PTE:text-style "PTE-text" 0 1 "ROMANS.SHX" "GHS.SHX") (setvar 'cmdecho 0) (setvar 'dimzin 0) (setq i 0 sum 0. lst '() rlst '() ss (PTE:ss->obj (ssget "_:L" '((0 . "LWPOLYLINE,CIRCLE")))) ) (setq __siz (cond ( (getreal (strcat "\n Enter text size. <" (rtos (setq __siz (cond ( __siz ) ( 3. )) ) 2 1 ) ">: " ) ) ) ( __siz ) ) ) (setq __zin (cond ( (getint (strcat "\n Enter decimal point factor. <" (itoa (setq __zin (cond ( __zin ) ( 2 )) ) ) ">: " ) ) ) ( __zin ) ) ) (foreach obj ss (setq mm (PTE:MinMax obj) obj2 obj area (vlax-curve-getarea obj) sum (+ area sum) ) (setq txt (PTE:Text (mapcar '/ (mapcar '+ (car mm) (cadr mm)) (list 2 2)) (strcat (itoa (setq i (1+ i))) "-" (rtos area 2 __zin)) 10 __siz ) ) (vla-put-layer txt "2") (vla-put-stylename txt "PTE-text") (setq react (vlr-pers (vlr-object-reactor (list obj2) (list txt i) '( (:vlr-modified . PTE:area-reactor-m) (:vlr-erased . PTE:area-reactor-e) ) ) ) ) (setq rlst (append rlst (list react))) (setq lst (append lst (list (list (itoa i) (rtos area 2 __zin))))) ) (if (vlax-method-applicable-p (setq space (vlax-get-property (setq doc (vla-get-activedocument (vlax-get-acad-object))) (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace) ) ) 'AddTable ) (progn (setq lst (append lst (list (list "ToTal" (rtos sum 2 __zin))))) (setq tobj (PTE:temp110919 space (setq pt (getpoint "\nPick the point for table")) "{\\Fromans|c0;\\C3;Area Table}" lst __siz ) ) (mapcar '(lambda ( re ) (vlr-data-set re (append (vlr-data re) (list tobj __zin)) ) ) rlst ) ) (princ "\n** This cad ver. don't service table. **") ) (PTE:end)(princ) ) ;;===========================================;; ;; CallBack Func. - 01 ;; ;;===========================================;; (defun PTE:area-table-arrange ( reactor area zin / table sum i ) (defun PTE:Mtext ( txt / len1 len2 ) (while (and (setq len1 (vl-string-search "\;" txt)) (setq len2 (vl-string-search "\\" txt)) ) (setq len1 (1+ len1) len2 (1+ len2) txt (vl-string-subst "" (substr txt len2 (1+ (- len1 len2))) txt) ) ) (while (and (setq len1 (vl-string-search "{" txt)) (setq len2 (vl-string-search "}" txt)) ) (setq txt (vl-string-subst "" "{" txt) txt (vl-string-subst "" "}" txt) ) ) txt ) ;;;__ (setq table (caddr (vlr-data reactor)) sum 0 i 0 ) (if (not (vlax-erased-p table)) (progn (vla-settext table (itoa (cadr (vlr-data reactor))) 1 (strcat "{\\Fromans|c0;\\C2;" area "}")) (repeat (- (vla-get-rows table) 2) (setq i (1+ i)) (setq sum (+ sum (atof (PTE:Mtext (vla-gettext table i 1))))) ) (vla-settext table (- (vla-get-rows table) 1) 1 (strcat "{\\Fromans|c0;\\C30;" (rtos sum 2 zin) "}")) ) ) ) ;;===========================================;; ;; CallBack Func. - 02 ;; ;;===========================================;; (defun PTE:area-reactor-m ( owner reactor param / zin area txt ) (if (not (vlax-erased-p owner)) (progn (setq zin (cadddr (vlr-data reactor)) area (rtos (vlax-curve-getarea owner) 2 zin) ) (if (not (vlax-erased-p (setq txt (car (vlr-data reactor))))) (vla-put-textstring txt (strcat (itoa (cadr (vlr-data reactor))) "-" area)) ) (PTE:area-table-arrange reactor area zin) ) )(princ) ) ;;===========================================;; ;; CallBack Func. - 03 ;; ;;===========================================;; (defun PTE:area-reactor-e ( owner reactor param / ) (setq zin (cadddr (vlr-data reactor))) (PTE:area-table-arrange reactor "-" zin) (vlr-remove reactor) (princ) ) Regards, M.R. HTH. 1 1 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.