Modify this lisp please
(defun C:mynewarea (/ acsp adoc ar axss txht maxp minp obj p1 p2 pc1 pc2 per
ss txts txt1 txt2)
(vl-load-com)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark (vla-get-activedocument
(vlax-get-acad-object)))
(setQ txht (vlax-get (vlax-ename->vla-object(car (entsel "\nSelect TEXT to match height: "))) 'Height))
(prompt "\n Select OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq
ar (vl-catch-all-apply
(function (lambda()
(vlax-curve-getarea obj)))))))
(not
(vl-catch-all-error-p
(setq
per (vl-catch-all-apply
(function (lambda()
(vlax-curve-getdistatparam obj
(vlax-curve-getendparam obj)))))))))
(progn
(setq txt2 (strcat "Area= " (rtos ar 2 2)))
(setq txt3 (strcat "Perimeter= " (rtos per 2 2)))
(setq pc1 (getpoint "\nPick Insertion point."))
(setq pc2 (mapcar '- pc1 (list 0 (* txht 1.5) 0)))
(setq pc3 (mapcar '- pc2 (list 0 (* txht 1.5) 0)))
;(setq pc4 (mapcar '- pc3 (list 0 (* txht 1.5) 0)))
(command "text" pc2 txht "" txt2)
(command "text" pc3 txht "" txt3)
)
)
)
)
)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object)))
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Here is updated code that keeps text height after first selection.
I have also repaired some other errors.
(defun C:mynewarea (/ *error* acsp adoc ar axss maxp minp obj p1 p2 pc1 pc2 pc3 per
ss txts txt2 txt3)
(defun *error* ( msg )
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(if adoc (vla-endundomark adoc))
(princ)
)
(vl-load-com)
(setq adoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-endundomark adoc)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)
(if (not txht)(setQ txht (vlax-get (vlax-ename->vla-object(car (entsel "\nSelect TEXT to match height: "))) 'Height)))
(prompt "\n Select OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq
ar (vl-catch-all-apply
(function (lambda()
(vlax-curve-getarea obj)))))))
(not
(vl-catch-all-error-p
(setq
per (vl-catch-all-apply
(function (lambda()
(vlax-curve-getdistatparam obj
(vlax-curve-getendparam obj)))))))))
(progn
(setq txt2 (strcat "Area= " (rtos ar 2 2)))
(setq txt3 (strcat "Perimeter= " (rtos per 2 2)))
(setq pc1 (getpoint "\nPick Insertion point."))
(setq pc2 (mapcar '- pc1 (list 0 (* txht 1.5) 0)))
(setq pc3 (mapcar '- pc2 (list 0 (* txht 1.5) 0)))
;(setq pc4 (mapcar '- pc3 (list 0 (* txht 1.5) 0)))
(command "text" pc2 txht "" txt2)
(command "text" pc3 txht "" txt3)
)
)
)
)
)
(vla-endundomark adoc)
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)If you need to change text height use following function
(defun C:mynewarea_text_height()
(setQ txht (vlax-get (vlax-ename->vla-object(car (entsel "\nSelect TEXT to match height: "))) 'Height))
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
I hope this is it.
(defun C:mynewarea
(/ *error* m e acsp adoc ar axss maxp minp obj p1 p2 pc1 pc2 pc3 per ss txts txt2 txt3)
(defun *error* ( msg )
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(if adoc (vla-endundomark adoc))
(setvar 'cmdecho 1)
(princ)
)
(defun set_text ( )
(setq e (car (entsel "\nSelect TEXT to match height: ")))
(if e (setq m (vlax-get (vlax-ename->vla-object e) 'Height)))
m
)
(vl-load-com)
(setq adoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-endundomark adoc)
(if (and(= (getvar "tilemode") 0)(= (getvar "cvport") 1))
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)
(setq m (set_text))
(if (and m) (setq txht m))
(cond ((and txht)
(prompt "\n Select OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq ar
(vl-catch-all-apply
(function (lambda() (vlax-curve-getarea obj)))
)
)
)
)
(not
(vl-catch-all-error-p
(setq per
(vl-catch-all-apply
(function (lambda()(vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
)
)
)
)
)
(progn
(setvar 'cmdecho 0)
(setq
txt2 (strcat "Area= " (rtos ar 2 2))
txt3 (strcat "Perimeter= " (rtos per 2 2))
pc1 (getpoint "\nPick Insertion point.")
pc2 (mapcar '- pc1 (list 0 (* txht 1.5) 0))
pc3 (mapcar '- pc2 (list 0 (* txht 1.5) 0))
)
(command "text" pc2 txht "" txt2)
(command "text" pc3 txht "" txt3)
(setvar 'cmdecho 1)
)
)
)
)
)
)
(T (princ "\nYou ahould set inital text height. Start again!"))
)
(vla-endundomark adoc)
(princ "\nDOne!")
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@Philip-John wrote:
Working perfectly.
If you don't mind, can you do a small modification also.
Presently first time I hit 'Enter' without selecting any text it shows the error "You should set initial text height. Start again!"instead please modify as follows:
1. When I hit 'Enter' without selecting any text (for first time), it should prompt for "Enter new text height:".[ ]. And it should not move forward without getting a value unless I hit 'Esc'
2. When I hit 'Enter' without selecting any text (next time onwards), again it should prompt for "Enter new text height:".[1.5]. (here 1.5 is previously entered value OR previously selected text height).
Sorry for disturbing you again.
Regards..
(setq txht 2.5)
(defun C:mynewarea
(/ *error* m e acsp adoc ar axss maxp minp obj p1 p2 pc1 pc2 pc3 per ss txts txt2 txt3)
(defun *error* ( msg )
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(if adoc (vla-endundomark adoc))
(setvar 'cmdecho 1)
(princ)
)
(defun set_text ( tht)
(if (and tht)
(setq e (car (entsel (strcat "\nSelect TEXT to match height: <" (rtos tht 2 2) "> "))))
(setq e (car (entsel "\nSelect TEXT to match height: ")))
)
(if e (setq m (vlax-get (vlax-ename->vla-object e) 'Height)))
m
)
(vl-load-com)
(setq adoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-endundomark adoc)
(if (and(= (getvar "tilemode") 0)(= (getvar "cvport") 1))
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)
(setq m (set_text txht))
(if (and m) (setq txht m))
(cond ((and txht)
(prompt "\n Select OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq ar
(vl-catch-all-apply
(function (lambda() (vlax-curve-getarea obj)))
)
)
)
)
(not
(vl-catch-all-error-p
(setq per
(vl-catch-all-apply
(function (lambda()(vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
)
)
)
)
)
(progn
(setvar 'cmdecho 0)
(vla-highlight obj :vlax-true)
(setq
txt2 (strcat "Area= " (rtos ar 2 2))
txt3 (strcat "Perimeter= " (rtos per 2 2))
pc1 (getpoint "\nPick Insertion point.")
pc2 (mapcar '- pc1 (list 0 (* txht 1.5) 0))
pc3 (mapcar '- pc2 (list 0 (* txht 1.5) 0))
)
(command "text" pc2 txht "" txt2)
(command "text" pc3 txht "" txt3)
(setvar 'cmdecho 1)
(vla-highlight obj :vlax-false)
)
)
)
)
)
)
(T (princ "\nEnter new text height by selecting text object!"))
)
(vla-endundomark adoc)
(princ "\nDone!")
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)
I have modified your original code so it works how it does. It is supposed that you select some text entity to collect its height. I would do it by simply entering text value. If global value is not set it exits so that you don't receive error message, and it also informs you to make selection. Code is created the way this function usually work.
I have added option to sequentially highlight objects according to selection order so you don't have to remember it in case of large number of selected object.
I have set default value of text height to 2.5 in firs line
(setq txht 2.5)
Change it according to your needs.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Hi @hak_vz
Thanks for your lisp.
I need different text in different locations. So setting a default value is difficult for me.
I request you to modify your lisp to (if possible):
1. First time if I hit 'Enter' without selecting any match text height, it should prompt for "Specify Text height:". (see image below).
2. If I hit 'Enter' without selecting any match text height, it should prompt for "Specify Text height:" showing the previously selected height. (see image below).
Regards..
Try this
(setq txht (getvar 'textsize))
(defun C:mynewarea
(/ *error* m e acsp adoc ar axss maxp minp obj p1 p2 pc1 pc2 pc3 per ss txts txt2 txt3)
(defun *error* ( msg )
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(if adoc (vla-endundomark adoc))
(setvar 'cmdecho 1)
(princ)
)
(defun set_text ( tht)
(if (and tht)
(setq e (getreal(strcat "\nEnter text size: <" (rtos tht 2 2) "> ")))
(setq e (getreal "\nEnter text size: "))
)
e
)
(vl-load-com)
(setq adoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-endundomark adoc)
(if (and(= (getvar "tilemode") 0)(= (getvar "cvport") 1))
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)
(setq m (set_text txht))
(if (and m) (setq txht m))
(cond ((and txht)
(prompt "\nSelect OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq ar
(vl-catch-all-apply
(function (lambda() (vlax-curve-getarea obj)))
)
)
)
)
(not
(vl-catch-all-error-p
(setq per
(vl-catch-all-apply
(function (lambda()(vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
)
)
)
)
)
(progn
(setvar 'cmdecho 0)
(vla-highlight obj :vlax-true)
(setq
txt2 (strcat "Area= " (rtos ar 2 2))
txt3 (strcat "Perimeter= " (rtos per 2 2))
pc1 (getpoint "\nPick Insertion point.")
pc2 (mapcar '- pc1 (list 0 (* txht 1.5) 0))
pc3 (mapcar '- pc2 (list 0 (* txht 1.5) 0))
)
(command "text" pc2 txht "" txt2)
(command "text" pc3 txht "" txt3)
(setvar 'cmdecho 1)
(vla-highlight obj :vlax-false)
)
)
)
)
)
)
)
(vla-endundomark adoc)
(princ "\nDone!")
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)
Change input text how you like inside "\n "
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
It is somehow unusual way of taking text height since you always have to pick some entity (and there is seldom need to change text sizes at every function repeat since it holds last value) but if you need it I hope this is it.
If you don't select text entity you are asked to enter text height (here you have to enter a value before continuation).
PS to exit function do not use ESC key since some object may stay highlighted.
(setq *txht* (getvar 'textsize))
(defun C:mynewarea
(/ *error* m e acsp adoc ar axss maxp minp obj p1 p2 pc1 pc2 pc3 per ss txts txt2 txt3)
(defun *error* ( msg )
(if (not (member msg '("Function cancelled" "quit / exit abort")))
(princ (strcat "\nError: " msg))
)
(if adoc (vla-endundomark adoc))
(setvar 'cmdecho 1)
(princ)
)
(defun set_text (tht / e m)
(setq e (car (entsel (strcat "\nSelect TEXT to match heigh <" (rtos tht 2 2) ">: "))))
(if e (setq m (vlax-get (vlax-ename->vla-object e) 'Height)))
(initget (+ 1 2 4))
(if (not e)(setq m (getreal (strcat "\nSpecify TEXT height <" (rtos tht 2 2) ">: "))))
m
)
(vl-load-com)
(setq adoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-endundomark adoc)
(if (and(= (getvar "tilemode") 0)(= (getvar "cvport") 1))
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)
(setq m (set_text *txht*))
(if (and m) (setq *txht* m))
(cond ((and *txht*)
(prompt "\n Select OBJECTS on screen to add area label")
(if (setq ss (ssget))
(progn
(setq axss (vla-get-activeselectionset adoc))
(vlax-for obj axss
(if
(and
(not
(vl-catch-all-error-p
(setq ar
(vl-catch-all-apply
(function (lambda() (vlax-curve-getarea obj)))
)
)
)
)
(not
(vl-catch-all-error-p
(setq per
(vl-catch-all-apply
(function (lambda()(vlax-curve-getdistatparam obj (vlax-curve-getendparam obj))))
)
)
)
)
)
(progn
(setvar 'cmdecho 0)
(vla-highlight obj :vlax-true)
(setq
txt2 (strcat "Area= " (rtos ar 2 2))
txt3 (strcat "Perimeter= " (rtos per 2 2))
pc1 (getpoint "\nPick Insertion point.")
pc2 (mapcar '- pc1 (list 0 (* *txht* 1.5) 0))
pc3 (mapcar '- pc2 (list 0 (* *txht* 1.5) 0))
)
(command "text" pc2 *txht* "" txt2)
(command "text" pc3 *txht* "" txt3)
(setvar 'cmdecho 1)
(vla-highlight obj :vlax-false)
)
)
)
)
)
)
(T (princ "\nEnter new text height by selecting text object!"))
)
(vla-endundomark adoc)
(princ "\nDone!")
(princ)
)
(princ "\n Type mynewarea to label objects with area and perimeter text")
(princ)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
hi @hak_vz ,
Thanks again...
Everything working fine as expected
But it shows an error when I hit 'Enter' button to accept the previous vale. (see below video)
@Philip-John wrote:
hi @hak_vz ,
Thanks again...
Everything working fine as expected
But it shows an error when I hit 'Enter' button to accept the previous vale. (see below video)
I have tested code in any possible situation and it works as expected. Maybe it is not written the way I would do it myself, but since I took your code for modification it is fixed to some reasonable extent.
What you receive is a expected result. Function initget is stopping you to continue code execution as long as you don't have predefined text height (either by selection or entering). Code prevents you to hit enter in that case and asks you to define it. Global variable that holds text size is set to nil i.e. it is not initialized.
Save your code in separate file with extension .lst and assure that first line above the code is added to that file.
(setq *txth* 2.5) - see the original code. For a first run you really need some value of text height to start with.
Once you start learning autolisp (any CAD user should know at least the basics) and writing your code you will understand what I'm talking about.
PS. Be regular with your responses (check forum regularly). When I see green circle on for two days and see no reply from OP I generally lose interest for that request. This all could have been resolved in one or two days.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
