;; 출 처 : http://www.lee-mac.com
;; 제 목 : Align Text, MText or Attribute to Curve
;; 버 전 : V1.1
;; 명령어 : CAT
;; 사용법 :
;;---------------=={ Curve Aligned Text }==-------------------;;
;; ;;
;; Prompts user for a selection of a Text, MText or ;;
;; Attribute entity, or a text string to be used in a new ;;
;; Text or MText entity. ;;
;; ;;
;; Selected entity is subsequently aligned dynamically to a ;;
;; selected curve object, offering additional controls ;;
;; displayed at the command line to refine the alignment. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.1 - 07-04-2011 ;;
;;------------------------------------------------------------;;
(defun c:CAT nil (c:CurveAlignedText))
(defun c:CurveAlignedText
( /
;; Local Functions
*error*
_gettextproperties
_layerlocked
_putmiddlecenter
;; Local Variables
cobj
e
ismtext isnested
object objtype
sel spc
textproperties tobj tsze
xang
;; Global Variables
; *curvestring *txtback *txtoffs *txtperp
)
(setq ObjType "MTEXT") ;; Default Object to create
(mapcar
(function
(lambda ( sym value ) (or (boundp sym) (set sym value)))
)
'(*TxtPerp *TxtOffs *TxtBack) (list (/ pi 2.) 1.0 :vlax-false)
)
(defun *error* ( msg )
(if
(and isNested cObj
(not
(vlax-erased-p
(setq cObj (vlax-ename->vla-object cObj))
)
)
)
(vla-delete cObj)
)
(if (and tObj (not (vlax-erased-p tObj)))
(if TextProperties
(mapcar
(function
(lambda ( property )
(if (and (cadr property) (vlax-property-available-p tObj (car property) t))
(vl-catch-all-apply 'vlax-put-property (cons tObj property))
)
)
)
TextProperties
)
(vla-delete tObj)
)
)
(if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)
(defun _GetTextProperties ( object )
(vl-remove-if 'null
(mapcar
(function
(lambda ( property )
(if (vlax-property-available-p object property)
(list property (vlax-get-property object property))
)
)
)
'(Alignment AttachmentPoint InsertionPoint TextAlignmentPoint BackgroundFill Rotation)
)
)
)
(defun _PutMiddleCenter ( object )
(
(lambda ( data )
(apply 'vlax-put-property (cons object (cdr data)))
(car data)
)
(if (eq "AcDbMText" (vla-get-ObjectName object))
(list 'InsertionPoint 'AttachmentPoint acAttachmentPointMiddleCenter)
(list 'TextAlignmentPoint 'Alignment acAlignmentMiddleCenter )
)
)
)
(defun _LayerLocked ( layer )
(= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" layer)))))
)
(LM:ActiveSpace 'doc 'spc)
(cond
( (_LayerLocked (getvar 'CLAYER))
(princ "\n** Current Layer Locked **")
)
(t
(while
(progn
(setq sel
(LM:SelectionOrText
(strcat "\nSelect or Type Text"
(if *CurveString (strcat " <" *CurveString "> : ") ": ")
)
2
)
)
(cond
(
(eq 'STR (type sel))
(if (not (and (zerop (strlen sel)) (not *CurveString)))
(vla-put-Visible
(setq tObj
(
(lambda ( string )
(if (eq "MTEXT" (strcase ObjType))
(vla-AddMText spc (vlax-3D-point '(0. 0. 0.))
(
(lambda ( box ) (- (caadr box) (caar box)))
(textbox
(list
(cons 1 (strcat string "A"))
(cons 40 (getvar 'TEXTSIZE))
(cons 7 (getvar 'TEXTSTYLE))
)
)
)
string
)
(vla-AddText spc string (vlax-3D-point '(0. 0. 0.)) (getvar 'TEXTSIZE))
)
)
(setq *CurveString
(cond
(
(< 0 (strlen sel)) sel
)
( *CurveString )
)
)
)
)
:vlax-false
)
)
nil
)
(
(and (vl-consp sel) (eq 'ENAME (type (car sel))))
(if (not (wcmatch (cdr (assoc 0 (entget (car sel)))) "MTEXT,TEXT,ATTRIB"))
(princ "\n** Object must be Text, MText or Attribute **")
(if (_LayerLocked (cdr (assoc 8 (entget (car sel)))))
(princ "\nObject on Locked Layer.")
(not (setq tObj (vlax-ename->vla-object (car sel)) TextProperties (_GetTextProperties tObj)))
)
)
)
)
)
)
(if
(and tObj
(progn
(while
(progn (setvar 'ERRNO 0) (setq sel (nentsel "\nSelect Curve to Align Text: "))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\n--> Missed, Try Again.")
)
( (eq 'ENAME (type (setq e (car sel))))
(cond
( (eq "VERTEX" (cdr (assoc 0 (entget e))))
(not (setq sel (list (cdr (assoc 330 (entget e))))))
)
( (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getEndParam (list e)))
(princ "\n--> Invalid Object Selected.")
)
)
)
)
)
)
sel
)
)
(progn
(if (setq isNested (= 4 (length sel)))
(
(lambda ( entity )
(vla-transformby (vlax-ename->vla-object entity) (vlax-tMatrix (caddr sel)))
)
(setq cObj (entmakex (append (entget (car sel)) '((60 . 1)))))
)
(setq cObj (car sel))
)
(setq tSze (vla-get-Height tObj))
(if (setq isMText (eq "AcDbMText" (vla-get-ObjectName tObj)))
(vla-put-Backgroundfill tObj *TxtBack)
)
(setq xAng (angle '(0. 0. 0.) (trans (getvar 'UCSXDIR) 0 (trans '(0. 0. 1.) 1 0 t))))
(
(lambda ( property / msg gr code data cPt Ang dis )
(setq msg
(princ
(strcat "\nAlign Text: [+/-] for [O]ffset, [P]erpendicular"
(if isMText ", [B]ackground Mask" "")
)
)
)
(vla-put-Visible tObj :vlax-true)
(while
(progn
(setq gr (grread 't 15 0) code (car gr) data (cadr gr))
(cond
(
(= 5 code)
(setq cPt (vlax-curve-getClosestPointto cObj (setq data (trans data 1 0)))
Ang (angle cPt data))
(vlax-put-property tObj property (vlax-3D-point (polar cPt Ang (* tSze *TxtOffs))))
(vla-put-rotation tObj ( (lambda ( a ) (if isMText (- a xAng) a)) (LM:MakeReadable (+ Ang *TxtPerp))))
t
)
(
(= 2 code)
(cond
(
(member data '(80 112))
(setq *TxtPerp (- (/ pi 2.) *TxtPerp))
)
(
(member data '(45 95))
(setq *TxtOffs (- *TxtOffs 0.1))
)
(
(member data '(43 61))
(setq *TxtOffs (+ *TxtOffs 0.1))
)
(
(and (member data '(66 98)) isMText)
(vlax-put tObj 'BackgroundFill
(setq *TxtBack (~ (vlax-get tObj 'BackgroundFill)))
)
(if (zerop *TxtBack)
(princ "\n<< Background Mask Off >>")
(princ "\n<< Background Mask On >>")
)
(princ msg)
t
)
(
(member data '(79 111))
(setq *TxtOffs
(cond
(
(setq dis
(getdist
(strcat "\nSpecify Text Offset <"
(rtos (* *TxtOffs tSze)) "> : "
)
)
)
(/ dis tSze)
)
( *TxtOffs )
)
)
(princ msg)
)
(
(member data '(13 32)) nil
)
( t )
)
)
(
(= code 25) nil
)
(
(= code 3)
(setq cPt (vlax-curve-getClosestPointto cObj (setq data (trans data 1 0)))
Ang (angle cPt data))
(vlax-put-property tObj property (vlax-3D-point (polar cPt Ang (* tSze *TxtOffs))))
(vla-put-rotation tObj ( (lambda ( a ) (if isMText (- a xAng) a)) (LM:MakeReadable (+ Ang *TxtPerp))))
)
)
)
)
)
(_PutMiddleCenter tObj)
)
(if
(and isNested cObj
(not
(vlax-erased-p
(setq cObj (vlax-ename->vla-object cObj))
)
)
)
(vla-delete cObj)
)
)
)
)
)
(princ)
)
;;----------------=={ Selection or Text }==-------------------;;
;; ;;
;; Prompts the user for an entity selection or text entry ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; prmpt - prompt to display ;;
;; cur - cursor type to display (0=Normal,1=None,2=Pick) ;;
;;------------------------------------------------------------;;
;; Returns: Entered string, selection data list, else nil ;;
;;------------------------------------------------------------;;
(defun LM:SelectionOrText ( prmpt cur ) (and prmpt (princ prmpt))
(
(lambda ( result / gr code data )
(while
(progn (setq gr (grread t 15 cur) code (car gr) data (cadr gr))
(cond
( (and (= 3 code) (listp data))
(setq result (nentselp data)) nil
)
( (= 2 code)
(cond
( (<= 32 data 126)
(setq result (strcat result (princ (chr data))))
)
( (= 13 data)
nil
)
( (and (= 8 data) (< 0 (strlen result)))
(setq result (substr result 1 (1- (strlen result))))
(princ (vl-list->string '(8 32 8)))
)
( t )
)
)
( (= 25 code) nil
)
( t )
)
)
)
result
)
""
)
)
;;--------------------=={ ActiveSpace }==---------------------;;
;; ;;
;; Retrieves pointers to the Active Document and Space ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; *doc - quoted symbol (other than *doc) ;;
;; *spc - quoted symbol (other than *spc) ;;
;;------------------------------------------------------------;;
(defun LM:ActiveSpace ( *doc *spc )
(set *spc
(vlax-get-property
(set *doc
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(if (= 1 (getvar 'CVPORT)) 'PaperSpace 'ModelSpace)
)
)
)
;;-------------------=={ Make Readable }==--------------------;;
;; ;;
;; Returns an angle corrected for text readability ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; a - angle to process ;;
;;------------------------------------------------------------;;
;; Returns: angle corrected for text readability ;;
;;------------------------------------------------------------;;
(defun LM:MakeReadable ( a )
(
(lambda ( a )
(cond
( (and (> a (/ pi 2)) (<= a pi))
(- a pi)
)
( (and (> a pi) (<= a (/ (* 3 pi) 2)))
(+ a pi)
)
( a )
)
)
(rem a (* 2 pi))
)
)
;;------------------------------------------------------------;;
(vl-load-com)
(princ)
(princ "\n:: CurveAlignedText.lsp | Version 1.1 | ?Lee Mac 2011 www.lee-mac.com ::")
(princ "\n:: Type \"CurveAlignedText\" or \"CAT\" to invoke ::")
(princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;
댓글 없음:
댓글 쓰기
즐거운 하루되세요...^^