TheSwamp
Code Red => AutoLISP (Vanilla / Visual) => Topic started by: SKUI_BREAKER on August 04, 2008, 02:48:11 PM
-
DOES anyone know anything about this lisp routine i found it at my work but i can't find anyone on the web who has it,
it works great but there is one small problem it doesn't work with polylines like it says it will
if anyone can figure what happened to it, that made it stop working with plines, please let me know. i think it had to be one of those revisions that was made to it.
;; This is "LineLetter" -- a lisp program that breaks a line, an arc,
;; a polyline, a circle, or an ellipse
;; and places text at the break at the angle of the entity where the break
;; is made.
;; ver. 1.04
;; added GetLetterWidth function to kind of determine width of text and
;; width factor
;;
;; ver. 1.05
;; added GetNearer to fix osnap "near" problems
;;
;; ver. 1.06
;; added GetText to have default text ability
;;
;; ver. 1.07 (by Andy Pilson, 03-02-2001)
;; added LAY variable. Stores line layer info.
;; added change command to change text to LAY variable and COLOR 30.
(setq ver "1.06") ;; version number; change when updates are made
(princ (strcat "\n\n'LineLetter' Ver. " ver "\n"))
;;custom error handler
(defun d_err (st)
(princ (strcat "\nError: " st "\n"))
(terpri)
(ResetDefaults)
(setq *error* old_err) ;;reset old error handler
(princ)
);;error
(defun C:LineLtr (/ pt1 aline TheLine entity tsize TextHeight TheAngle ts
TheText TextAngle old_cmdecho old_regen old_osmode
old_err textwidth theent SaveDefaults SetSetvars
ResetDefaults LBreak RightEnt GetTextAngle
GetTextHeight GetLetterWidth GetNearer LAY)
;;save system defaults
(defun SaveDefaults ()
(setq old_cmdecho (getvar "CMDECHO"))
(setq old_regen (getvar "REGENMODE"))
(setq old_osmode (getvar "OSMODE"))
(setq old_aunits (getvar "AUNITS"))
(setq old_highl (getvar "HIGHLIGHT"))
);;SaveDefaults
;;set system variables
(defun SetSetvars ()
(setvar "CMDECHO" 0)
(setvar "REGENMODE" 0)
(setvar "OSMODE" 512)
(setvar "AUNITS" 0)
(setvar "HIGHLIGHT" 0)
);; SetSetvars
;;reset system variables to previous values
(defun ResetDefaults ()
(setvar "CMDECHO" old_cmdecho)
(setvar "REGENMODE" old_regen)
(setvar "OSMODE" old_osmode)
(setvar "AUNITS" old_aunits)
(setvar "HIGHLIGHT" old_highl)
(redraw theent)
);;ResetDefaults
(setq C_LAY (GETVAR "CLAYER"))
;;routine to break line according to text length
(defun LBreak (pt1 TheAngle len theent / LetterLen b1 b2)
(setq LetterLen (/ len 1.5))
(setq b1 (polar pt1 TheAngle LetterLen))
(setq b2 (polar pt1 (+ TheAngle 3.14) LetterLen))
(command "BREAK" theent b1 b2)
);;end LBreak
;;routine to get correct entity name
(defun RightEnt (entity aline / nxtent seqend theent)
(if (= entity "VERTEX")
(progn
(setq nxtent (entnext (car aline)))
(setq seqend (cdr (assoc 0 (entget nxtent))))
(while (/= seqend "SEQEND")
(setq nxtent (entnext nxtent))
(setq seqend (cdr (assoc 0 (entget nxtent))))
);;end while
(setq theent (cdr (assoc -2 (entget nxtent))))
);;end progn
(setq theent (car aline));;else
);;end if
);;end RightEnt
;;get rotation angle of text according to entity type
(defun GetTextAngle (entity TheLine pt1)
(if (= entity "LINE")
(angle (cdr (assoc 10 TheLine)) (cdr (assoc 11 theline)))
(if (= entity "VERTEX")
(angle pt1 (cdr (assoc 10 TheLine)))
(- (angle (cdr (assoc 10 TheLine)) pt1) (dtr 90))
);;end if
);;end if
);;end GetTextAngle
;; decide whether text height is fixed or not and act accordingly
(defun GetTextHeight()
(princ "\n")
(setq ts (tblsearch "STYLE" (getvar "TEXTSTYLE")) ;;'ts' is global now
TextHeight nil) ;;TextHeight is also global
(if (= (cdr (assoc 40 ts)) 0.0)
(progn
(initget 6)
(setq TextHeight (getreal (strcat "\nEnter text height <"
(rtos (getvar "TEXTSIZE") 2 1) ">: ")))
(if (null TextHeight)
(setq TextHeight (getvar "TEXTSIZE"))
(setvar "TEXTSIZE" TextHeight)
);;end if
);;end progn
);;end if
(cdr (assoc 41 ts)) ;;returns text width factor
);;end GetTextHeight
;; determine width of letters to make correct break size
(defun GetLetterWidth (TheText height width / thin fat len a letter)
(if (null height)
(setq height (cdr (assoc 40 ts)))
);;end if
(setq thin (list "f" "I" "i" "j" "l" "t" "1")
fat (list "m" "M" "w" "W")
len 0
a 1
);;end setq
(setq letter (substr TheText a 1))
(while (/= letter "")
(if (/= (member letter thin) nil)
(setq len (+ len (* height (* width 1))))
(if (/= (member letter fat) nil)
(setq len (+ len (* height (* width 1))))
(setq len (+ len (* height width)))
);;end if
);;end if
(setq a (+ a 1)
letter (substr TheText a 1)
);;end setq
);;end while
(setq len len)
);;end GetLetterWidth
;;routine in lieu of the hardly functional "near" osnap
(defun GetNearer (entity theline pt1 / np1 np2 np4 nxtent)
(setq np1 (cdr (assoc 10 theline)))
(if (or (= entity "LINE") (= entity "VERTEX"))
(progn
(if (= entity "LINE")
(setq np2 (cdr (assoc 11 theline)))
(progn ;;else VERTEX
(setq nxtent (entnext (cdr (assoc -1 theline))))
(setq np2 (cdr (assoc 10 (entget nxtent)))) ;;find 2nd point
);;end progn
);;end if
(setq np4 (polar pt1 (- (angle np1 np2) (dtr 90)) 1))
(inters np1 np2 pt1 np4 nil) ;;returns point on line
);;end progn
(progn ;;else entity is arc or circle
(setq np2 (cdr (assoc 40 theline)))
(polar np1 (angle np1 pt1) np2) ;;returns point on arc
);;end progn
);;end if
);;end GetNearer
;;check for default text
(defun GetText (/ thetext)
(if (null ll_txt) ;;ll_txt is global, contains default text
(progn
(initget 1)
(princ "\nEnter letter(s): ")
);;end progn
(progn ;;else
(princ "\nEnter letter(s)/<")
(princ (strcat ll_txt ">: "))
);;end progn
);;end if
(setq thetext (getstring))
(if (and (= thetext "") (/= ll_txt nil))
(setq thetext ll_txt)
(setq ll_txt thetext)
);;end if
);;end GetText
;;main program
(COMMAND "COLOR" "CYAN"); set current color to 30
(setq old_err *error*
*error* d_err)
(graphscr)
(SaveDefaults)
(SetSetvars)
(princ "\n\nThis works with lines, polylines, ellipses, circles, and arcs.")
(princ "\nSelect point on the entity where text is to be inserted.\n")
(setq aline (nentsel))
(setq TheLine (entget (car aline)))
(setq lay (cdr (assoc 8 TheLine)));sets LAY to layer of line
(setq entity (cdr (assoc 0 TheLine)))
(if (and (or (= entity "LINE") (= entity "VERTEX") (= entity "ARC")
(= entity "CIRCLE")) (= (length (last aline)) 3))
(progn
(setq theent (RightEnt entity aline))
(redraw theent 3)
(setq pt1 (osnap (cadr aline) "near"))
(if (null pt1)
(progn
(setq pt1 (cadr aline))
(setq pt1 (GetNearer entity TheLine pt1))
);;end progn
);;end if
(setq textwidth (* (GetTextHeight) 1.2))
(setq TheAngle (GetTextAngle entity TheLine pt1))
(setq TheText (GetText))
(if (/= TheText "")
(progn
(if (and (> (rtd TheAngle) 95) (< (rtd TheAngle) 275))
(setq TextAngle (- (rtd TheAngle) 180))
(setq TextAngle (rtd TheAngle))
);;end if
(setq len (GetLetterWidth TheText TextHeight textwidth))
(LBreak pt1 TheAngle len theent)
(setvar "OSMODE" 0)
(cond
(TextHeight
(command "TEXT" "J" "M" pt1 TextHeight TextAngle TheText))
((null TextHeight)
(command "TEXT" "J" "M" pt1 TextAngle TheText))
);;end cond
);;end progn
(princ "\n\nNo text. No break.")
);;end if
);;end progn
(princ "\n\nEntity picked is not the correct type.\n")
);;end if
(ResetDefaults)
(setq *error* old_err)
(princ)
(command "CHANGE" "L" "" "P" "LA" LAY ""); changes text to LAY
(COMMAND "COLOR" "BYLAYER")
(COMMAND ".layer" "set" c_lay "")
);;end LineLtr
(princ "Type LINELTR to start.")
(princ)
;;end program
-
I've not seen this lisp before. The reason it quit working is that it works with old style plines not the LWplines.
-
You should write a new lisp for that using the vlax-curve functions.
Here is the pseudo code.
Get user text string, use global var for default on ENTER
Loop while picking vlax-curve objects, exit on Enter
Get point on object
Get angle of object
create text on object
use TEXTBOX to get rectangle around text
trim object to rectangle
end loop
-
DOES THAT MEAN the whole thing will have to be rewritten or is there something small that can be done to it.
i wish i knew autolisp well enough to be able to troubleshoot but as it stands i i dont think autocad will be around much longer if my company switches to revit
-
not that autocad wont be around much longer but the demand for drawings in autocad from where i am at
-
Hey there SKUI_BREAKER, here's a rewrite that should work in most any situation. The only case I think it will fail is if you select an object on a locked layer.
Enjoy!
;;rewrite of old code to label an object and break that object at the label
;; original author was not listed in the code. Rewrite by Jeff Mishler, Aug. 4, 2008
(defun c:LabelLTR (/ ANG DERIV DOC ENT HGT OBJ PARAM PICK PT SPACE TXT TXTOBJ)
(vl-load-com)
;; decide whether text height is fixed or not and act accordingly
(defun GetTextHeight(/ ts textheight)
(princ "\n")
(setq ts (tblsearch "STYLE" (getvar "TEXTSTYLE"))
TextHeight nil)
(if (= (cdr (assoc 40 ts)) 0.0)
(progn
(initget 6)
(setq TextHeight (getreal (strcat "\nEnter text height <"
(rtos (getvar "TEXTSIZE") 2 1) ">: ")))
(if (null TextHeight)
(setq TextHeight (getvar "TEXTSIZE"))
(setvar "TEXTSIZE" TextHeight)
);;end if
);;end progn
);;end if
);;end GetTextHeight
(defun GetText (/ thetext)
(if (null ll_txt) ;;ll_txt is global, contains default text
(progn
(initget 1)
(princ "\nEnter letter(s): ")
);;end progn
(progn ;;else
(princ "\nEnter letter(s)/<")
(princ (strcat ll_txt ">: "))
);;end progn
);;end if
(setq thetext (getstring))
(if (and (= thetext "") (/= ll_txt nil))
(setq thetext ll_txt)
(setq ll_txt thetext)
);;end if
);;end GetText
;;use the same TextHeight & Text until the user restarts the routine
(setq hgt (gettextheight)
txt (GetText)
)
;;loop until nothing selected
(while (and
(setq pick (entsel "\nSelect object to label: "))
(wcmatch (cdr (assoc 0 (entget (setq ent (car pick))))) "LINE,ARC,CIRCLE,*POLYLINE,SPLINE,ELLIPSE")
)
(setq obj (vlax-ename->vla-object ent)
pt (cadr pick)
doc (vla-get-activedocument (vlax-get-acad-object))
)
(setq pt (vlax-curve-getclosestpointto obj pt)
param (vlax-curve-getparamatpoint obj pt)
deriv (vlax-curve-getfirstderiv obj param)
)
(if (= (car deriv) 0.0)
(setq ang (/ pi 2))
(setq ang (atan (/ (cadr deriv) (car deriv))))
)
;;check text angle
(if (and (< ang (- (* pi 1.5) 0.0872));; use 0.0872r for 5 degrees
(< (+ (* pi 0.5)0.0872) ang)
)
(setq ang (+ ang pi))
)
(setq space (if (= (getvar "CVPORT") 1)
(vla-get-paperspace doc)
(vla-get-modelspace doc)
)
)
(setq txtobj (vlax-invoke space 'addtext txt pt hgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vlax-put txtobj 'textalignmentpoint pt)
(vla-put-rotation txtobj ang)
(command ".trim" (entlast) "" (list ent pt) "")
)
(princ)
)
-
thanxs its works perfectly
-
i want to find the part that specifies what color the text will be but i dont see it.
-
i want to find the part that specifies what color the text will be but i dont see it.
It uses the current text style...If you want to change the color use (vla-put-color txtobj 1) at the end of the routine.
If you use color bylayer, then you will have to put the text object on your layer (vla-put-layer txtobj 'layername") *layer has to exist or it will bomb.
-
Ooops, I neglected to note that the original routine set the color to CYAN and the layer to that of the line being labelled....here it is with these included.
;;rewrite of old code to label an object and break that object at the label
;; original author was not listed in the code. Rewrite by Jeff Mishler, Aug. 4, 2008
(defun c:LabelLTR (/ ANG DERIV DOC ENT HGT OBJ PARAM PICK PT SPACE TXT TXTOBJ)
(vl-load-com)
;; decide whether text height is fixed or not and act accordingly
(defun GetTextHeight(/ ts textheight)
(princ "\n")
(setq ts (tblsearch "STYLE" (getvar "TEXTSTYLE"))
TextHeight nil)
(if (= (cdr (assoc 40 ts)) 0.0)
(progn
(initget 6)
(setq TextHeight (getreal (strcat "\nEnter text height <"
(rtos (getvar "TEXTSIZE") 2 1) ">: ")))
(if (null TextHeight)
(setq TextHeight (getvar "TEXTSIZE"))
(setvar "TEXTSIZE" TextHeight)
);;end if
);;end progn
);;end if
);;end GetTextHeight
(defun GetText (/ thetext)
(if (null ll_txt) ;;ll_txt is global, contains default text
(progn
(initget 1)
(princ "\nEnter letter(s): ")
);;end progn
(progn ;;else
(princ "\nEnter letter(s)/<")
(princ (strcat ll_txt ">: "))
);;end progn
);;end if
(setq thetext (getstring))
(if (and (= thetext "") (/= ll_txt nil))
(setq thetext ll_txt)
(setq ll_txt thetext)
);;end if
);;end GetText
;;use the same TextHeight & Text until the user restarts the routine
(setq hgt (gettextheight)
txt (GetText)
)
;;the version of the TrueColor object changes with each Acad MAJOR version change.
(setq tcolor (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.17"))
(vla-put-colorindex tcolor accyan)
;;loop until nothing selected
(while (and
(setq pick (entsel "\nSelect object to label: "))
(wcmatch (cdr (assoc 0 (entget (setq ent (car pick))))) "LINE,ARC,CIRCLE,*POLYLINE,SPLINE,ELLIPSE")
)
(setq obj (vlax-ename->vla-object ent)
pt (cadr pick)
doc (vla-get-activedocument (vlax-get-acad-object))
)
(setq pt (vlax-curve-getclosestpointto obj pt)
param (vlax-curve-getparamatpoint obj pt)
deriv (vlax-curve-getfirstderiv obj param)
)
(if (= (car deriv) 0.0)
(setq ang (/ pi 2))
(setq ang (atan (/ (cadr deriv) (car deriv))))
)
;;check text angle
(if (and (< ang (- (* pi 1.5) 0.0872));; use 0.0872r for 5 degrees
(< (+ (* pi 0.5)0.0872) ang)
)
(setq ang (+ ang pi))
)
(setq space (if (= (getvar "CVPORT") 1)
(vla-get-paperspace doc)
(vla-get-modelspace doc)
)
)
(setq txtobj (vlax-invoke space 'addtext txt pt hgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vlax-put txtobj 'textalignmentpoint pt)
(vla-put-rotation txtobj ang)
(vla-put-truecolor txtobj tcolor)
(vla-put-layer txtobj (vla-get-layer obj))
(command ".trim" (entlast) "" (list ent pt) "")
)
(princ)
)
-
WHAT DOes VLA mean or do and how does it differ from vlax
i almost said that your thing didn't work but i figured out there was a " missing in the front where i put the specific layername.
but works nonethe less.
(setq txtobj (vlax-invoke space 'addtext txt pt hgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vlax-put txtobj 'textalignmentpoint pt)
(vla-put-rotation txtobj ang)
(vla-put-layer txtobj '"layername")
(command ".trim" (entlast) "" (list ent pt) "")
-
TO further this lisp to an even more user specific routine i wonder if this could lisp could use only capitol letters to prevent lowercase letters from being used :?
-
TO further this lisp to an even more user specific routine i wonder if this could lisp could use only capitol letters to prevent lowercase letters from being used :?
Change:
(setq hgt (gettextheight)
txt (GetText)
)
To:
(setq hgt (gettextheight)
txt (strcase (GetText))
)
-
got it
-
WHAT ABOUT changing the lisp to not break the line but instead add text that has a background mask factor of 1.0
-
WHAT ABOUT changing the lisp to not break the line but instead add text that has a background mask factor of 1.0
Replace this:
(setq txtobj (vlax-invoke space 'addtext txt pt hgt))
(vla-put-alignment txtobj acAlignmentMiddleCenter)
(vlax-put txtobj 'textalignmentpoint pt)
(vla-put-rotation txtobj ang)
(vla-put-truecolor txtobj tcolor)
(vla-put-layer txtobj (vla-get-layer obj))
(command ".trim" (entlast) "" (list ent pt) "")
With this:
(setq txtobj (vlax-invoke space 'addmtext pt 0.0 txt))
(vla-put-attachmentpoint txtobj acMiddleCenter)
(vla-put-insertionpoint txtobj (vlax-3d-point pt))
(vla-put-rotation txtobj ang)
(vla-put-truecolor txtobj tcolor)
(vla-put-backgroundfill txtobj :vlax-true)
(vla-put-layer txtobj (vla-get-layer obj))
-
it doesn't seem to apply the background mask and it didn't give the mtext a defined width so the mask has got and idea of what area it is covering
-
Try adding the vla-put-width
(setq txtobj (vlax-invoke space 'addmtext pt 0.0 txt))
(vla-put-attachmentpoint txtobj acMiddleCenter)
(vla-put-insertionpoint txtobj (vlax-3d-point pt))
(vla-put-rotation txtobj ang)
(vla-put-truecolor txtobj tcolor)
(vla-put-width txtobj (cadadr (textbox (entget (vlax-vla-object->ename txtobj)))))
(vla-put-backgroundfill txtobj :vlax-true)
(vla-put-layer txtobj (vla-get-layer obj))
-
my 2008 is not turning the darned background mask on BUT I AM pretty sure the width is working right :-(
-
OK THE WIDTH ISN'T WORKING EITHER NOW THAT i think about it maybe should have a version that does 1.5 offset factor and one that does 1.0 factor
i tried to combine two lisp i have but that didn't work either
i have a seperate lisp that will apply a background mask to the mtext i choose so i figured i would insert that and tell it to select "last" object but still no luck.