Guest ego Posted August 21, 2018 Share 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 Link to comment Share on other sites More sharing options...
CADTutor Posted August 21, 2018 Share 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 Link to comment Share on other sites More sharing options...
marko_ribar Posted August 21, 2018 Share 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 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.