[编程交流] Lisp程序请调整。。。

<p>(defun c:renum    (/ oldPref oldSuf oldStart curText curStr vlaObj keepText)</p><p> </p><p>  (vl-load-com)</p><p> </p><p>  (defun TTC_Paste  (pasteStr keepText / sslst vlaObj)</p><p>    (if    (setq ss (ssget))</p><p>      (progn</p><p>    (setq sslst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))</p><p>    (foreach ent sslst</p><p>    (cond</p><p>           ((= "DIMENSION" (cdr (assoc 0 (entget ent))))</p><p>        (setq vlaObj (vlax-ename->vla-object ent)</p><p>              oldStat (vla-get-Measurement vlaObj))</p><p>        (if keepText</p><p>          (if (= (vla-get-TextOverride vlaObj) "")</p><p>            (setq pasteStr</p><p>               (strcat</p><p>                 pasteStr</p><p>                 (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))</p><p>            (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))</p><p>        (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextOverride (list vlaObj pasteStr)))</p><p>          (princ "\n Can't paste. Object may be on locked layer. "))) ; end condition #1</p><p>           ((= "ACAD_TABLE" (cdr (assoc 0 (entget ent))))</p><p>        (setq vlaObj (vlax-ename->vla-object ent))</p><p>        (if keepText</p><p>          (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))</p><p>        (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString (list vlaObj pasteStr)))</p><p>          (princ "\nError. Can't paste text. ")</p><p>          (entupd ent))) ; end condition # 2</p><p>           ((= "INSERT" (cdr (assoc 0 (entget ent))))</p><p>        (princ "\nCan't paste to block's DText or MText. ")) ; end condition #3</p><p>           ((member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF")) ; end and</p><p>        (setq vlaObj (vlax-ename->vla-object ent))</p><p>        (if keepText</p><p>          (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))</p><p>        (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString (list vlaObj pasteStr)))</p><p>          (princ "\nError. Can't pase text. "))) ; end condition #4</p><p>           (T (princ "\nCan't paste. Invalid object. ")) ; end condition #5</p><p>           ))</p><p>         T) ; end progn</p><p>      nil) ; end if</p><p>    ) ;_TTC_PASTE</p><p> </p><p> </p><p>  (setq aDoc (vla-get-ActiveDocument (vlax-get-acad-object)))</p><p>  (vla-StartUndoMark aDoc)</p><p>  (if (not rnm:Pref)</p><p>    (setq rnm:Pref ""))</p><p>  (if (not rnm:Suf)</p><p>    (setq rnm:Suf ""))</p><p>  (if (not rnm:Start)</p><p>    (setq rnm:Start 1))</p><p>  (setq    oldPref     rnm:Pref</p><p>    oldSuf     rnm:Suf</p><p>    oldStart rnm:Start) ; end setq</p><p>  (setq rnm:Pref (getstring T (strcat "\nType prefix: : ")))</p><p>  (if (= "" rnm:Pref)</p><p>    (setq rnm:Pref oldPref))</p><p>  (if (= " " rnm:Pref)</p><p>    (setq rnm:Pref ""))</p><p>  (setq rnm:Suf (getstring T (strcat "\nType suffix: : ")))</p><p>  (if (= "" rnm:Suf)</p><p>    (setq rnm:Suf oldSuf)) ;(if(= " " rnm:Suf)(setq rnm:Suf ""))</p><p>  (setq    rnm:Start (getint (strcat "\nEnter start number </p><p>                  (itoa rnm:Start)</p><p>                  ">: ")))</p><p>  (if (null rnm:Start)</p><p>    (setq rnm:Start oldStart))</p><p>  (initget "Yes No Ä</p>