[编程交流] 复制带有字段的标记

(defun c:axx (/ *error* ss ob n at pn pv) (vl-load-com)
 (defun *error* (msg)
   (if (not (wcmatch (strcase msg t) "*cancel*,*exit*"))
     (princ (strcat "\nError: " msg))) 
   (if ss (redraw (ssname ss 0) 4)) (princ))
 (if (setq ss (ssget ":s" (list (cons 0 "insert"))))
   (progn (redraw (ssname ss 0) 3)
     (if (setq ob (ssget (list (cons 0 "insert"))))
       (progn
         (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))                
         (repeat (setq n (sslength ob)) (setq n (1- n))
           (foreach at (vlax-invoke (vlax-ename->vla-object (ssname ss 0)) 'Getattributes)
             (setq pn (vlax-get-property at 'TagString)
                   pv (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vlax-get-property at 'ObjectId)) ">%).TextString>%"))
             (foreach at (vlax-invoke (vlax-ename->vla-object (ssname ob n)) 'GetAttributes) 
               (if (eq (vla-get-TagString at) pn) (vlax-put-property at "TextString" pv))))
          (vl-cmdf "._updatefield" (ssname ob n) "") 
         ) 
         (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
         (redraw (ssname ss 0) 4)
       )
     ) 
   )
 ) (if ss (redraw (ssname ss 0) 4)) (princ)
)