Выравнивание текста по кривой (lisp)

Deadylka · 04.06.2012, 02:12

Добрый вечер)

Есть лисп с помощью которого можно выравнивать текст по любой кривой... так вот там есть функция, при нажатии на кнопку P текст поворачивается только на 90 градусов... (если нажать 2 раз, то текст вернется обратно).

Так вот... был бы признателен, если кто нибудь допишет код, чтоб текст поворачивался при нажатии на P дальше по 90 градусов
т.е. 0, 90, 180, 360.

Нормальный текст(какой вы видите с экрана))), повернутый, кверхтормашками, повернутый в другую сторону)

Спасибо)

Вот код:

Код:

[Выделить все]

 
;; ;; 
;; 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 McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 

(defun c:cat nil (c:CurveAlignedText)) 

(defun c:CurveAlignedText 

( / *error* GetTextProperties PutMiddleCenter 

COBJ 
ISMTEXT ISNESTED 
OBJECT OBJTYPE 
SEL SPC 
TEXTPROPERTIES TOBJ TSZE 
XANG 
) 

(vl-load-com) 
;; © Lee Mac 2010 

(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) 
) 
) 

(or (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 ) 
) 
) 
) 

(LM:ActiveSpace 'doc 'spc) 

(cond 
( 
(= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (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 **") 
(not (setq tObj (vlax-ename->vla-object (car sel)) TextProperties (GetTextProperties tObj))) 
) 
) 
) 
) 
) 

(if (and tObj (setq Sel (LM:SelectifFoo LM:isCurveObject "\nSelect Curve to Align Text: " t))) 
(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 McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 
;; 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 ) 
;; © Lee Mac 2010 
(and prmpt (princ prmpt)) 
( 
(lambda ( result / gr code data ) 
(while 
(progn 
(setq gr (grread t 13 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 McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 
;; Arguments: ;; 
;; *doc - quoted symbol other than *doc ;; 
;; *spc - quoted symbol other than *spc ;; 
;;------------------------------------------------------------;; 

(defun LM:ActiveSpace ( *doc *spc ) 
;; © Lee Mac 2010 
(set *spc 
(if 
(or 
(eq AcModelSpace 
(vla-get-ActiveSpace 
(set *doc 
(vla-get-ActiveDocument 
(vlax-get-acad-object) 
) 
) 
) 
) 
(eq :vlax-true (vla-get-MSpace (eval *doc))) 
) 
(vla-get-ModelSpace (eval *doc)) 
(vla-get-PaperSpace (eval *doc)) 
) 
) 
) 

;;-------------------=={ Select if Foo }==--------------------;; 
;; ;; 
;; Continuous selection prompts until the predicate function ;; 
;; foo is validated ;; 
;;------------------------------------------------------------;; 
;; Author: Lee McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 
;; Arguments: ;; 
;; foo - predicate function taking ename argument ;; 
;; str - prompt string ;; 
;; nest - T to allow nested object selection ;; 
;;------------------------------------------------------------;; 
;; Returns: Selection information as returned by (n)entsel ;; 
;;------------------------------------------------------------;; 

(defun LM:SelectifFoo ( foo str nest / sel ) 
;; © Lee Mac 2010 
(while 
(progn 
(setq sel ((if nest nentselp entsel) str)) 

(cond 
( 
(vl-consp sel) 

(if (not (foo (car sel))) 
(princ "\n** Invalid Object Selected **") 
) 
) 
) 
) 
) 
sel 
) 

;;------------------=={ Is Curve Object }==-------------------;; 
;; ;; 
;; Returns True if supplied ename argument is a CurveObject ;; 
;;------------------------------------------------------------;; 
;; Author: Lee McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 
;; Arguments: ;; 
;; ent - Entity name to test ;; 
;;------------------------------------------------------------;; 
;; Returns: T if ename points to a CurveObject, else nil ;; 
;;------------------------------------------------------------;; 

(defun LM:isCurveObject ( ent ) 
;; © Lee Mac 2010 
(not 
(vl-catch-all-error-p 
(vl-catch-all-apply 
(function vlax-curve-getEndParam) (list ent) 
) 
) 
) 
) 

;;-------------------=={ Make Readable }==--------------------;; 
;; ;; 
;; Returns an angle corrected for text readability ;; 
;;------------------------------------------------------------;; 
;; Author: Lee McDonnell, 2010 ;; 
;; ;; 
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; 
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; 
;;------------------------------------------------------------;; 
;; Arguments: ;; 
;; a - angle to process ;; 
;;------------------------------------------------------------;; 
;; Returns: angle corrected for text readability ;; 
;;------------------------------------------------------------;; 

(defun LM:MakeReadable ( a ) 
;; © Lee Mac 2010 
( 
(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)) 
) 
) 

(princ) 
(princ "\n:: CurveAlignedText.lsp | Copyright © 2010 by Lee McDonnell ::") 
(princ "\n:: Type \"CurveAlignedText\" or \"CAT\" to invoke ::") 
(princ)

TararykovDG · 04.06.2012, 09:34

Могу предложить альтернативный вариант Вставка объектов под заданным углом к кривой

VVA · 04.06.2012, 09:47

Без проверки.
Найди такую строчку

Код:

[Выделить все]

(vla-put-rotation tObj ( (lambda ( a ) (if isMText (- a xAng) a)) (LM:MakeReadable (+ Ang *TxtPerp))))

Замени на

Код:

[Выделить все]

(vla-put-rotation tObj ( (lambda ( a ) (if isMText (- a xAng) a)) (+ Ang *TxtPerp)))

TararykovDG · 04.06.2012, 09:50

VVA, не все, еще надо

Код:

[Выделить все]

(setq *TxtPerp (- (/ pi 2.) *TxtPerp))

заменить на

Код:

[Выделить все]

(setq *TxtPerp (+ *TxtPerp (/ pi 2.)))

Deadylka · 05.06.2012, 11:15

Всё работает, спасибо большое!

Вот код если кому надо:

Код:

[Выделить все]

 ;;---------------=={ 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 McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;

(defun c:cat nil (c:CurveAlignedText))

(defun c:CurveAlignedText
   
   ( / *error* GetTextProperties PutMiddleCenter

       COBJ
       ISMTEXT ISNESTED
       OBJECT OBJTYPE
       SEL SPC
       TEXTPROPERTIES TOBJ TSZE
       XANG
   )
  
  (vl-load-com)
  ;; © Lee Mac 2010

  (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)
      )
    )
    
    (or (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      )
      )
    )
  )

  (LM:ActiveSpace 'doc 'spc)

  (cond
    (
      (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (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 **")
                (not (setq tObj (vlax-ename->vla-object (car sel)) TextProperties (GetTextProperties tObj)))
              )
            )
          )
        )
      )

      (if (and tObj (setq Sel (LM:SelectifFoo LM:isCurveObject "\nSelect Curve to Align Text: " t)))
        (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)) (+ Ang *TxtPerp)))

                      t
                    )
                    (
                      (= 2 code)

                      (cond
                        (
                          (member data '(80 112))

                          (setq *TxtPerp (+ *TxtPerp (/ pi 2.)))
                        )
                        (
                          (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)) (+ 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 McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  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 )
  ;; © Lee Mac 2010
  (and prmpt (princ prmpt))
  (
    (lambda ( result / gr code data )  
      (while
        (progn
          (setq gr (grread t 13 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 McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  *doc - quoted symbol other than *doc                      ;;
;;  *spc - quoted symbol other than *spc                      ;;
;;------------------------------------------------------------;;

(defun LM:ActiveSpace ( *doc *spc )
  ;; © Lee Mac 2010
  (set *spc
    (if
      (or
        (eq AcModelSpace
          (vla-get-ActiveSpace
            (set *doc
              (vla-get-ActiveDocument
                (vlax-get-acad-object)
              )
            )
          )
        )
        (eq :vlax-true (vla-get-MSpace (eval *doc)))
      )
      (vla-get-ModelSpace (eval *doc))
      (vla-get-PaperSpace (eval *doc))
    )
  )
)

;;-------------------=={ Select if Foo }==--------------------;;
;;                                                            ;;
;;  Continuous selection prompts until the predicate function ;;
;;  foo is validated                                          ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  foo  - predicate function taking ename argument           ;;
;;  str  - prompt string                                      ;;
;;  nest - T to allow nested object selection                 ;;
;;------------------------------------------------------------;;
;;  Returns:  Selection information as returned by (n)entsel  ;;
;;------------------------------------------------------------;;

(defun LM:SelectifFoo ( foo str nest / sel )
  ;; © Lee Mac 2010
  (while
    (progn
      (setq sel ((if nest nentselp entsel) str))
      
      (cond
        (
          (vl-consp sel)

          (if (not (foo (car sel)))
            (princ "\n** Invalid Object Selected **")
          )
        )
      )
    )
  )
  sel
)
    
;;------------------=={ Is Curve Object }==-------------------;;
;;                                                            ;;
;;  Returns True if supplied ename argument is a CurveObject  ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ent - Entity name to test                                 ;;
;;------------------------------------------------------------;;
;;  Returns:  T if ename points to a CurveObject, else nil    ;;
;;------------------------------------------------------------;;

(defun LM:isCurveObject ( ent )
  ;; © Lee Mac 2010
  (not
    (vl-catch-all-error-p
      (vl-catch-all-apply
        (function vlax-curve-getEndParam) (list ent)
      )
    )
  )
)

;;-------------------=={ Make Readable }==--------------------;;
;;                                                            ;;
;;  Returns an angle corrected for text readability           ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  a - angle to process                                      ;;
;;------------------------------------------------------------;;
;;  Returns:  angle corrected for text readability            ;;
;;------------------------------------------------------------;;

(defun LM:MakeReadable ( a )
  ;; © Lee Mac 2010
  (
    (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))
  )
)

(princ)
(princ "\n:: CurveAlignedText.lsp | Copyright © 2010 by Lee McDonnell ::")
(princ "\n:: Type \"CurveAlignedText\" or \"CAT\" to invoke ::")
(princ)

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива	Profan	Готовые программы	272	06.06.2021 23:12
Выравнивание текста	pasha_1977	AutoCAD	12	16.03.2020 18:27
Выравнивание текста и блоков относительно кривой.	Jeriko	Программирование	18	11.06.2014 14:43
LISP. Выравнивание текста по двум точкам.	Krieger	Готовые программы	10	24.12.2011 16:02
Изменение форматированного текста посредством lisp	Tramp	LISP	4	03.03.2006 11:28

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск