[编程交流] 单线te周围的多段线

(defun c:Test (/ ss)
 (if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
   (progn (sssetfirst nil ss)
          (vla-sendcommand
            (cond (*AcadDoc*)
                  ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
            )
            "_.TCIRCLE 0.3 RECTANGLES VARIABLE "
          )
   )
 )
 (princ)
)

(defun c:tBox ( / ss )
 ;; © Lee Mac 2010
 (if
   (and
     (setq ss  (ssget '((0 . "TEXT"))))
     (setq *o*
       (cond
         (
           (getdist
             (strcat "\nSpecify Offset <"
               (rtos
                 (setq *o*
                   (cond ( *o* ) ( (* 0.5 (getvar 'TEXTSIZE)) ))
                 )
               )
               "> : "
             )
           )
         )
         ( *o* )
       )
     )
   )
   (
     (lambda ( i / e )
       (while (setq e (ssname ss (setq i (1+ i))))
         (entmakex
           (append
             (list
               (cons 0 "LWPOLYLINE")
               (cons 100 "AcDbEntity")
               (cons 100 "AcDbPolyline")
               (assoc 8 (entget e))
               (cons 90 4)
               (cons 70 1)
               (cons 38 (caddr (dxf 10 (entget e))))
               (assoc 210 (entget e))
             )
             (mapcar '(lambda ( x ) (cons 10 x)) (LM:TextBox e *o*))
           )
         )
       )
     )
     -1
   )
 )
 (princ)
)
                        
(defun dxf ( code lst ) (cdr (assoc code lst)))
;;---------------------=={ Text Box }==-----------------------;;
;;                                                            ;;
;;  Returns the coordinates (in OCS) of the rectangle         ;;
;;  enclosing the specified Text entity with specified offset ;;
;;------------------------------------------------------------;;
;;  Author: Lee McDonnell, 2010                               ;;
;;                                                            ;;
;;  Copyright © 2010 by Lee McDonnell, All Rights Reserved.   ;;
;;  Contact: Lee Mac @ TheSwamp.org, CADTutor.net             ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  ent    - Text Entity                                      ;;
;;  offset - Optional offset                                  ;;
;;------------------------------------------------------------;;
;;  Returns:  List of Points (in OCS) framing the text        ;;
;;------------------------------------------------------------;;
(defun LM:TextBox ( ent offset / el base ang m )
 ;; © Lee Mac 2010
 
 (if (eq "TEXT" (dxf 0 (setq el (entget ent))))
   (mapcar
     (function
       (lambda ( x ) (mapcar (function +) (mxv m x) base))
     )
     (progn
       (setq base (reverse (cdr (reverse (dxf 10 el)))) ;; 2D OCS
             ang  (dxf 50 el) ;; to OCS X-axis
              m   (list
                    (list (cos ang) (- (sin ang)) 0)
                    (list (sin ang)    (cos ang)  0)
                    (list    0             0      1)
                  )
       )
       (
         (lambda ( data )
           (mapcar
             (function
               (lambda ( g )
                 (mapcar
                   (function
                     (lambda ( f ) ((eval f) data))
                   )
                   g
                 )
               )
             )
            '(
               (
                 (lambda ( x ) (- (caar   x) offset))
                 (lambda ( x ) (- (cadar  x) offset))
               )
               (
                 (lambda ( x ) (+ (caadr  x) offset))
                 (lambda ( x ) (- (cadar  x) offset))
               )
               (
                 (lambda ( x ) (+ (caadr  x) offset))
                 (lambda ( x ) (+ (cadadr x) offset))
               )
               (
                 (lambda ( x ) (- (caar   x) offset))
                 (lambda ( x ) (+ (cadadr x) offset))
               )
             )
           )
         )
         (textbox el)
       )
     )
   )
 )
)
(defun mxv ( m v )
 (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)