[编程交流] 将标注复制到文字替代

;;Dim override
(defun c:dimo (/ COPYDIM CURLAY DELSET DIMLST
      DIMSET ERRCOUNT LAYCOL LENT
      NEXTENT OVTEXT *ERROR* ACTDOC
      OLDECHO)
;;; Vladimir Smirnov {Smirnoff} on dwg.ru
 (defun *ERROR* (msg)
   (setvar "CMDECHO" oldEcho)
   ); end of error
 (vl-load-com)
 (setq oldEcho(getvar "CMDECHO")
actDoc(vla-get-ActiveDocument
              (vlax-get-acad-object))
layCol(vla-get-Layers actDoc)
); end setq
 (setvar "CMDECHO" 0)
 (if
   (setq dimSet
   (ssget "_:L" '((0 . "DIMENSION"))))
   (progn
     (setq dimLst
     (mapcar 'vlax-ename->vla-object 
                   (vl-remove-if 'listp 
                    (mapcar 'cadr(ssnamex dimSet))))
    ); end setq
     (vla-StartUndoMark actDoc)
     (foreach dim dimLst
             (vla-put-TextOverride dim (dim-get-text-string (vlax-vla-object->ename dim)))
(vla-put-Color dim 22)
       )
     (vla-EndUndoMark actDoc)
     ); end progn
   ); end if
 (setvar "CMDECHO" oldEcho)
 (princ)
 ); end of c:dimo
(defun Col_Item_Find (Collection Item / result)
 (if
   (not
     (vl-catch-all-error-p  
(setq result
       (vl-catch-all-apply 'vla-item
         (list Collection Item))))) 
   result
   ); end if
 ); end of Col_Item_Find
;;; Dim restore
(defun c:dimr (/ COPYDIM CURLAY DELSET DIMLST
      DIMSET ERRCOUNT LAYCOL LENT
      NEXTENT OVTEXT *ERROR* ACTDOC
      OLDECHO)
;;; Vladimir Smirnov {Smirnoff} on dwg.ru
 (defun *ERROR* (msg)
   (setvar "CMDECHO" oldEcho)
   ); end of error
 (vl-load-com)
 (setq oldEcho(getvar "CMDECHO")
actDoc(vla-get-ActiveDocument
              (vlax-get-acad-object))
layCol(vla-get-Layers actDoc)
); end setq
 (setvar "CMDECHO" 0)
 (if
   (setq dimSet
   (ssget '((0 . "DIMENSION"))))
   (progn
     (setq dimLst
     (mapcar 'vlax-ename->vla-object 
                   (vl-remove-if 'listp 
                    (mapcar 'cadr(ssnamex dimSet))))
    errCount 0
    ); end setq
     (vla-StartUndoMark actDoc)
     (foreach dim dimLst
(setq curLay(vla-get-Layer dim))
(if
  (/= :vlax-true
      (vla-get-Lock(Col_Item_Find layCol curLay)))
  (progn
(vla-put-TextOverride dim "<>")
(vla-put-Color dim 82)
); end progn
  (setq errCount(1+ errCount))
  ); end if
); end foreach
     (if(/= 0 errCount)
(princ
  (strcat "\n"
          (itoa errCount)" were on locked layer!"))
); end if
     (vla-EndUndoMark actDoc)
     ); end progn
   ); end if
 (setvar "CMDECHO" oldEcho)
 (princ)
)
(defun mip_MTEXT_Unformat ( Mtext / text Str )
 (setq MM Mtext)
 (setq Text "")
  (while (/= Mtext "")
       (cond
         ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
           (setq Mtext (substr Mtext 3) Text   (strcat Text Str)))
         ((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
         ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
   (setq Mtext (substr Mtext 3)))
         ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
           (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
  ((wcmatch (strcase (substr mtext 1 4)) "\\PQ[CRJD],\\PXQ")  ;;;Add by KPblC
   (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
   )
         ((wcmatch (strcase (substr Mtext 1 2)) "\\P")
           (if (or
           (zerop (strlen Text))
           (= " " (substr Text (strlen Text)))
           (= " " (substr Mtext 3 1)))
              (setq Mtext (substr Mtext 3))
              (setq Mtext (substr Mtext 3) Text (strcat Text " "))))
  ((wcmatch (strcase (substr Mtext 1 2)) "\\S")
           (setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
                 Text  (strcat Text (vl-string-translate "#^\" "/^\" Str))
                 Mtext (substr Mtext (+ 4 (strlen Str)))))
  (t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))))
 Text)
(defun dim-get-text-string ( dim / str)
(setq str "")
  (vlax-for item (vla-item (vla-get-blocks
                        (vla-get-activedocument (vlax-get-acad-object))
                      ) ;_ end of vla-get-Blocks
                      (cdr (assoc 2 (entget dim)))
            ) ;_ end of vla-item
    (if (vlax-property-available-p item 'Textstring)
         (setq str (vla-get-textstring item))
      )
    )
(mip_MTEXT_Unformat str)
 )
(princ "\nType Dimo to override and Dimr to restore")