[编程交流] 转换属性定义t

;=======================================================================
;    Atd2Text.Lsp                                    Feb 28, 2003
;    Change ATTDEF To Text Using Tag Name As Text Value
;================== Start Program ======================================
(princ "\nCopyright (C) 2003, Fabricated Designs, Inc.")
(princ "\nLoading Atd2Text v1.1 ")
(setq a2t_ nil lsp_file "Atd2Text")
;================== Macros =============================================
(defun PDot ()(princ "."))
(PDot);++++++++++++ Set Modes & Error ++++++++++++++++++++++++++++++++++
(defun a2t_smd ()
(SetUndo)
(setq olderr *error*
     *error* (lambda (e)
               (while (> (getvar "CMDACTIVE") 0)
                      (command))
               (and (/= e "quit / exit abort")
                    (princ (strcat "\nError: *** " e " *** ")))
               (command "_.UNDO" "_END" "_.U")
               (a2t_rmd))
      a2t_var '(("CMDECHO"   . 0) ("MENUECHO"   . 0)
                ("MENUCTL"   . 0) ("MACROTRACE" . 0)
                ("OSMODE"    . 0) ("SORTENTS"   . 119)
                ("BLIPMODE"  . 0) ("MODEMACRO" . ".")
                ("SNAPMODE"  . 0) ("UCSICON"    . 1)
                ("ORTHOMODE" . 0) ("GRIDMODE"   . 0)
                ("ELEVATION" . 0) ("THICKNESS"  . 0)
                ("HIGHLIGHT" . 0) ("REGENMODE"  . 1)
                ("CECOLOR"   . "BYLAYER")
                ("CELTYPE"   . "BYLAYER")))
(foreach v a2t_var
     (setq a2t_rst (cons (cons (car v) (getvar (car v))) a2t_rst))
     (setvar (car v) (cdr v)))
(princ (strcat (getvar "PLATFORM") " Release " (ver)
       " -  Convert ATTDEF to TEXT ....\n"))
(princ))
(PDot);++++++++++++ Return Modes & Error +++++++++++++++++++++++++++++++
(defun a2t_rmd ()
 (setq *error* olderr)
 (foreach v a2t_rst (setvar (car v) (cdr v)))
 (command "_.UNDO" "_END")
 (prin1))
(PDot);++++++++++++ Set And Start An Undo Group ++++++++++++++++++++++++
(defun SetUndo ()
(and (zerop (getvar "UNDOCTL"))
     (command "_.UNDO" "_ALL"))
(and (= (logand (getvar "UNDOCTL") 2) 2)
     (command "_.UNDO" "_CONTROL" "_ALL"))
(and (= (logand (getvar "UNDOCTL")  8)
     (command "_.UNDO" "_END"))
(command "_.UNDO" "_GROUP"))
(PDot);************ Main Program ***************************************
(defun a2t_ (/ olderr a2t_var a2t_rst st tc ss en ed i)
 (a2t_smd)
 (initget 1 "Tag Default Prompt")
 (setq st (getkword "\nMake Text Show ATTDEF -> Default/Prompt/Tag:   "))
 (cond ((= st "Tag")      (setq tc 2))
       ((= st "Prompt")   (setq tc 3))
       ((= st "Default")  (setq tc 1)))
 (while (not ss)
        (setq ss (ssget '((0 . "ATTDEF")))))
 (setq i (sslength ss))
 (princ (strcat "\nChanging " (rtos i 2 0) " ATTDEFs to TEXT\n"))
 (while (not (minusp (setq i (1- i))))
        (princ (strcat "\r" (rtos i 2 0) "         "))
        (setq en (ssname ss i)
              ed (entget en))
        (entdel en)
        (entmake (list (cons 0 "TEXT")
                       (cons 1 (cdr (assoc tc ed)))
                       (assoc 7 ed)
                       (assoc 8 ed)
                       (assoc 10 ed)
                       (assoc 11 ed)
                       (if (assoc 39 ed)
                           (assoc 39 ed)
                           (cons 39 0.0))
                       (assoc 40 ed)
                       (assoc 41 ed)
                       (assoc 50 ed)
                       (assoc 51 ed)
                       (if (assoc 62 ed)
                           (assoc 62 ed)
                           (cons 62 256))
                       (assoc 71 ed)
                       (assoc 72 ed)
                       (cons 73 (cdr (assoc 74 ed)))
                       (assoc 210 ed))))
 (a2t_rmd))
(PDot);************ Load Program ***************************************
(defun C:Atd2Text () (a2t_))
(if a2t_ (princ "\nAtd2Text Loaded\n"))
(prin1)
;|================== End Program =======================================

(defun c:AttDef2Text ( / ss )
 ;; © Lee Mac  ~  01.06.10
 (vl-load-com)
 (if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
   (
     (lambda ( i / e o )
       (while (setq e (ssname ss (setq i (1+ i))))
         (if
           (
             (if (and (vlax-property-available-p
                        (setq o (vlax-ename->vla-object e)) 'MTextAttribute)
                      (eq :vlax-true (vla-get-MTextAttribute o)))
               MAttDef2MText AttDef2Text
             )
             (entget e)
           )
           (entdel e)
         )
       )
     )
     -1
   )
 )
 (princ)
)
(defun AttDef2Text ( eLst / dx74 dx2 )
 ;; © Lee Mac  ~  01.06.10
 (setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))
 (entmake
   (append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
     (list
       (cons 73 dx74)
       (cons  1  dx2)
     )
   )
 )
)
(defun MAttDef2MText ( eLst )
 ;; © Lee Mac  ~  01.06.10
 (entmake
   (append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
     (RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
       (RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
     )
     (list (cons 1 (cdr (assoc 2 eLst))))
   )
 )
)
(defun RemoveFirstPairs ( pairs lst )
 ;; © Lee Mac
 (defun foo ( pair lst )
   (if lst
     (if (eq pair (caar lst))
       (cdr lst)
       (cons (car lst) (foo pair (cdr lst)))
     )
   )
 )
 (foreach pair pairs
   (setq lst (foo pair lst))
 )
 lst
)
(defun RemovePairs ( pairs lst )
 ;; © Lee Mac
 (vl-remove-if
   (function
     (lambda ( pair )
       (vl-position (car pair) pairs)
     )
   )
   lst
 )
)