Помогите переделать программу автоматической нумерации (Страница 1 из 2)

(defun _MIP_GET_ENTT ( prmpt myfilter sps / Bl e1 prname str aa e2 pt)
 (setq BL t)  ;_Признак выхода
 (while BL
  (setvar "ERRNO" 0)
  (setq e1 (entsel (strcat "\n" prmpt " <выход>:")))  ;_Выбор примитива
  (setq pt (cadr e1) e1 (car e1))  ;_pt - точка выбора e1 - имя примитива
  (if pt (setvar "LASTPOINT" pt))  ;_pt в LASTPOINT
  (if (member e1 sps)              ;_Есть e1 в списке?
  (progn
    (princ "Примитив уже выбран")  ;_Да Повторный выбор
  )
  (progn                           ;_Нет Анализируем дальше
   (if e1                          ;_А вообще что-то выбрано?
    (progn                                     ;_Да
      (setq prname (cdr(assoc 0 (entget e1)))) ;_Берем тип примитива (LINE ARC и т.д.)
      (if myfilter
   (progn
     (if (member prname myfilter)     ;_Есть ли тип в фильтре?
       (setq BL nil)                  ;_Да Bl-nil while прекращается
       (progn                         ;_Нет
         (setq str "\nПримитив должен быть типа\n") ;_Сообщение
         (foreach aa myfilter
      (setq str (strcat str aa " "))
         )
         (princ str)
       )
     )
   )
   (setq BL nil)     ;_Фильтра нет. while прекращаем
      )
    )
    (progn     ;_А вообще что-то выбрано? НЕТ
               ;_Анализируем почему
      (setq e2 (getvar "ERRNO"))  ;_Берем код ошибки
      (cond
           ((= e2 7) ;;;Пустой выбор
             (princ "Ничего не выбрано")
             (setq BL t)    ;_while продолжаем
            )
           ((= e2 52) ;;;Клавиша Ввод(выход)
             (setq BL nil e1 nil);_while прекращаем
            )
          (t (princ "Необходимо выбрать примитив")
             (setq BL t);_что-то другое while продолжаем
          )
      )
    )
   )
 )
)
  );_while
  e1              ;_Возвращаем имя примива
)
(defun c:sashrenpr(/ nach prim imprim spis subspis tpara pref)
  (initget 6)
  (setq nach (getint "Введите начальный номер:"))
  (setq pref (getstring "Введите префикс:"))
  (if (/= nach nil)
    (progn
      (setq prim (_MIP_GET_ENTT "\nУкажите заменяемое число:" '("TEXT" "MTEXT") nil))
     (while prim
       (setq     spis (entget prim)
         subspis (assoc 1 spis)
        tpara (vl-list* 1 (strcat pref (rtos nach)))
         spis (subst tpara subspis spis))
       (entmod spis)
       (setq nach (1+ nach))
       (setq prim (_MIP_GET_ENTT "\nУкажите заменяемое число:" '("TEXT" "MTEXT") nil))
     );end while
    )
  )
)

(strcat "\nType prefix: <"num:Pref">: ")))

(strcat "\nType suffix: <"num:Suf">: ")))

(strcat "\nType prefix:(If you whant to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))

(strcat "\nType suffix:(If you whant to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))

;;;https://www.caduser.ru/forum/topic29902.html
(defun c:num (/ oldPref oldSuf oldStart curStr newNum
           actDoc actSp oldEcho oldSize *error*)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (princ)
    ); end *error*
  (vl-load-com)
  (if(not num:Size)(setq num:Size(getvar "DIMTXT")))
  (if(not num:Pref)(setq num:Pref ""))
  (if(not num:Suf)(setq num:Suf ""))
  (if(not num:Num)(setq num:Num 1))
  (setq oldPref num:Pref
        oldSuf num:Suf
        oldStart num:Num
   oldSize num:Size
   actDoc(vla-get-ActiveDocument
      (vlax-get-acad-object))
   oldEcho(getvar "CMDECHO")
   ); end setq
  (setvar "CMDECHO" 0)
  (if(= (vla-get-ActiveSpace actDoc) 1)
    (setq actSp(vla-get-ModelSpace actDoc))
    (setq actSp(vla-get-PaperSpace actDoc))
    ); end setq
  (setq num:Size
    (getreal
      (strcat "\nSpecify text size <"(rtos num:Size)">: ")))
  (if(null num:Size)(setq num:Size oldSize))
  (setq num:Pref
    (getstring T
      (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))
  (if(= "" num:Pref)(setq num:Pref oldPref))
  (if(= " " num:Pref)(setq num:Pref ""))
  (setq num:Suf
    (getstring T
      (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Suf"> :")))
  (if(= "" num:Suf)(setq num:Suf oldSuf))
  (if(= " " num:Suf)(setq num:Suf ""))
  (setq num:Num
    (getint
      (strcat "\nEnter start number <"(itoa num:Num)">: ")))
  (if(null num:Num)(setq num:Num oldStart))
(while T
  (setq curStr(strcat num:Pref(itoa num:Num)num:Suf)
        newNum(vla-AddText actSp
        curStr (vlax-3d-point
       '(0.0 0.0 0.0)) num:Size))
  (vla-put-Alignment newNum acAlignmentMiddleCenter)
  (command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"")
  (command "_.erase" (entlast) "")
  (command "_.pasteclip" pause)
    (setq num:Num(1+ num:Num))
  ); end while
  (princ)
  ); end of c:num
;To keep contents of the text
;;;Routine for Renumbering
;;;Realization {Smirnoff}
;;;https://www.caduser.ru/forum/topic29902.html
;;;https://www.caduser.ru/forum/topic21894.html
;;;Edition 23.10.2006 Vladimir Azarko (VVA)
;;;https://www.caduser.ru/forum/topic30467.html
(defun c:renum (/ oldPref oldSuf oldStart curText curStr vlaObj keepText)
(vl-load-com)
(defun TTC_Paste(pasteStr keepText / nslLst vlaObj)
(if (setq nslLst(nentsel "\nPaste text <exit> >>"))
(progn (cond
((and (= 4(length nslLst))
 (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object (cdr(assoc -1(entget(car(last nslLst)))))))
(setq oldStat (vla-get-Measurement vlaObj))
(if keepText
 (if (= (vla-get-TextOverride vlaObj) "")
 (setq pasteStr (strcat pasteStr (rtos oldStat (vla-get-UnitsFormat vlaObj) (vla-get-PrimaryUnitsPrecision vlaObj))))
 (setq pasteStr (strcat pasteStr (vla-get-TextOverride vlaObj)))))
(if (vl-catch-all-error-p(vl-catch-all-apply 'vla-put-TextOverride(list vlaObj pasteStr)))
 (princ "\n Can't paste. Object may be on locked layer. "))); end condition #1
((and (= 4(length nslLst))
(= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. ")(entupd (car(last nslLst))))); end condition # 2
((and (= 4(length nslLst))
 (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))); end and
(princ "\nCan't paste to block's DText or MText. ")); end condition #3
((and (= 2(length nslLst))
(member(cdr(assoc 0(entget(car nslLst)))) '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))); end and
(setq vlaObj (vlax-ename->vla-object(car nslLst)))
(if keepText (setq pasteStr (strcat pasteStr (vla-get-TextString vlaobj))))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-TextString(list vlaObj pasteStr)))
(princ "\nError. Can't pase text. "))); end condition #4
(T (princ "\nCan't paste. Invalid object. ")); end condition #5
); end cond
T); end progn
nil); end if
);_TTC_PASTE
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object)))
(vla-StartUndoMark aDoc)
(if(not rnm:Pref)(setq rnm:Pref ""))(if(not rnm:Suf)(setq rnm:Suf ""))
(if(not rnm:Start)(setq rnm:Start 1))
(setq oldPref rnm:Pref oldSuf rnm:Suf oldStart rnm:Start); end setq
(setq rnm:Pref (getstring T
         (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))
(if(= "" rnm:Pref)(setq rnm:Pref oldPref))(if(= " " rnm:Pref)(setq rnm:Pref ""))
(setq rnm:Suf (getstring T
                (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Suf"> :")))
(if(= "" rnm:Suf)(setq rnm:Suf oldSuf))(if(= " " rnm:Suf)(setq rnm:Suf ""))
(setq rnm:Start (getint (strcat "\nEnter start number <"
(itoa rnm:Start)">: ")))
(if(null rnm:Start)(setq rnm:Start oldStart))
(initget "Yes No ?? ??? _Yes No Yes No")
(setq keepText (not (= "No" (getkword "\nkeep contents of the text [Yes/No] <Yes>:"))))
(setq rnm:Start (1- rnm:Start))
(while (TTC_Paste (setq curStr(strcat rnm:Pref(itoa (setq rnm:Start(1+ rnm:Start)))rnm:Suf)) keepText))
(vla-EndUndoMark aDoc)(princ)); end of c:renum
(defun c:ttc (/ actDoc vlaObj sObj sText curObj oldForm
        oType oldMode conFlag errFlag *error*)
  (vl-load-com)
      (setq actDoc(vla-get-ActiveDocument
        (vlax-get-acad-object)))
      (vla-StartUndoMark actDoc)
  (defun TTC_Paste(pasteStr / nslLst vlaObj hitPt
                   hitRes Row Column)
    (setq errFlag nil)
    (if
     (setq nslLst(nentsel "\nPaste text >"))
      (progn
  (cond
    (
     (and
       (= 4(length nslLst))
       (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst)))))))
     (if
       (vl-catch-all-error-p
         (vl-catch-all-apply
     'vla-put-TextOverride(list vlaObj pasteStr)))
         (progn
         (princ "\n Can't paste. Object may be on locked layer. ")
         (setq errFlag T)
         ); end progn
       ); end if
     ); end condition #1
    (
     (and
       (= 4(length nslLst))
       (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst))))))
     hitPt(vlax-3D-Point(trans(cadr nslLst)1 0))
     hitRes(vla-HitTest vlaObj hitPt
        (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column)
           ); end setq
     (if(= :vlax-true hitRes)
     (progn
         (if
     (vl-catch-all-error-p
       (vl-catch-all-apply
         'vla-SetText(list vlaObj Row Column pasteStr)))
     (progn
       (princ "\n Can't paste. Object may be on locked layer. ")
       (setq errFlag T)
       ); end progn
     ); end if
         ); end progn
       ); end if
     ); end condition # 2
    (
     (and
       (= 4(length nslLst))
       (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (princ "\nCan't paste to block's DText or MText. Select Attribute ")
     (setq errFlag T)
     ); end condition #3
    (
     (and
       (= 2(length nslLst))
         (member(cdr(assoc 0(entget(car nslLst))))
           '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object(car nslLst)))
        (if
     (vl-catch-all-error-p
       (vl-catch-all-apply
         'vla-put-TextString(list vlaObj pasteStr)))
    (progn
       (princ "\nError. Can't pase text. ")
      (setq errFlag T)
      ); end progn
     ); end if
     ); end condition #4
    (T
     (princ "\nCan't paste. Invalid object. ")
     (setq errFlag T)
     ); end condition #5
    ); end cond
             T
      ); end progn
            nil
           ); end if
    ); end of TTC_Paste
    (defun TTC_MText_Clear(Mtext / Text Str)
    (setq Text "")
    (while(/= Mtext "")
      (cond
  ((wcmatch
     (strcase
       (setq Str
        (substr Mtext 1 2)))
                     "\\[\\{}`~]")
   (setq Mtext(substr Mtext 3)
         Text(strcat Text Str)
   ); end setq
  ); end condition #1
  ((wcmatch(substr Mtext 1 1) "[{}]")
    (setq Mtext
     (substr Mtext 2))
  ); end condition #2
  (
   (and
   (wcmatch
     (strcase
       (substr Mtext 1 2)) "\\P")
   (/=(substr Mtext 3 1) " ")
    ); end and
         (setq Mtext (substr Mtext 3)
               Text (strcat Text " ")
         ); end setq
   ); end condition #3
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[LOP]")
    (setq Mtext(substr Mtext 3))
  ); end condition #4
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[ACFHQTW]")
    (setq Mtext
     (substr Mtext
       (+ 2
          (vl-string-search ";" Mtext))))
  ); end condition #5
  ((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)))
   ); end setq
   (print Str)
  ); end condition #6
  (T
   (setq Text(strcat Text(substr Mtext 1 1))
         Mtext (substr Mtext 2)
   )
  ); end condition #7
      ); end cond
    ); end while
  Text
); end of TTC_MText_Clear
  (defun TTC_Copy (/ sObj sText tType actDoc)
   (if
    (and
     (setq sObj(car(nentsel "\nCopy text... ")))
     (member(setq tType(cdr(assoc 0(entget sObj))))
      '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
     ); end and
    (progn
      (setq actDoc(vla-get-ActiveDocument
        (vlax-get-Acad-object))
      sText(vla-get-TextString
       (vlax-ename->vla-object sObj))
      ); end setq
      (if(= tType "MTEXT")
  (setq sText(TTC_MText_Clear sText))
  ); end if
      ); end progn
    ); end if
    sText
    ); end of TTC_Copy
  (defun CCT_Str_Echo(paseStr / comStr)
    (if(< 20(strlen paseStr))
      (setq comStr
       (strcat
         (substr paseStr 1 17)"..."))
      (setq comStr paseStr)
      ); end if
    (princ
      (strcat "\nText = \"" comStr "\""))
    (princ)
    ); end of CCT_Str_Echo
    (defun *error*(msg)
    (vla-EndUndoMark
      (vla-get-ActiveDocument
        (vlax-get-acad-object)))
    (princ "\nQuit TTC")
    (princ)
    ); end of *error*
    (if(not ttc:Mode)(setq ttc:Mode "Multiple"))
    (initget "Multiple Pair-wise")
    (setq oldMode ttc:Mode
    ttc:Mode
     (getkword
       (strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:Mode ">: "))
    conFlag T
    paseStr ""
     ); end setq
    (if(null ttc:Mode)(setq ttc:Mode oldMode))
    (if(= ttc:Mode "Multiple")
      (progn
  (if(and(setq paseStr(TTC_Copy))conFlag)
    (progn
    (CCT_Str_Echo paseStr)
    (while(setq conFlag(TTC_Paste paseStr))T
      ); end while
    ); end progn
    ); end if
  ); end progn
      (progn
  (while
    (and conFlag paseStr)
    (setq paseStr(TTC_Copy))
    (if(and paseStr conFlag)
      (progn
    (CCT_Str_Echo paseStr)
    (setq errFlag T)
    (while errFlag
    (setq conFlag(TTC_Paste paseStr))
         );end while
       ); end progn
      ); end if
    ); end while
  ); end progn
      ); end if
   (vla-EndUndoMark actDoc)
   (princ "\nQuit TTC")
  (princ)
  ); end c:ttc
;;Originally Posted by ASMI
;;http://www.cadtutor.net/forum/showthread.php?t=11114&page=2
(defun c:apnum (/ oldStart oldPref oldSuf oldEcho
        oldSize oldBlock temBl *error* att)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (setvar "ATTDIA" att)
    (princ)
    ); end *error*
  (if(not apnum:Size)(setq apnum:Size 1.0))
  (if(not apnum:Num)(setq apnum:Num 1))
  (if(not apnum:Pref)(setq apnum:Pref ""))
  (if(not apnum:Suf)(setq apnum:Suf ""))
  (setq  oldStart apnum:Num
   oldSize apnum:Size
   oldPref apnum:Pref
   oldSuf apnum:Suf
   oldEcho(getvar "CMDECHO")
   att (getvar "ATTDIA")
   ); end setq
  (setvar "ATTDIA" 0)(setvar "ATTREQ" 1)
  (setvar "CMDECHO" 0)
    (setq apnum:Pref
    (getstring T
      (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Pref"> :")))
  (if(= "" apnum:Pref)(setq apnum:Pref oldPref))
  (if(= " " apnum:Pref)(setq apnum:Pref ""))
  (setq apnum:Suf
    (getstring T
       (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"apnum:Suf"> :")))
  (if(= "" apnum:Suf)(setq apnum:Suf oldSuf))
  (if(= " " apnum:Suf)(setq apnum:Suf ""))
  (setq apnum:Num
    (getint
      (strcat "\nSpecify start number <"(itoa apnum:Num)">: ")))
  (if(null apnum:Num)(setq apnum:Num oldStart))
  (setq apnum:Size
    (getreal
      (strcat "\nSpecify block scale <"(rtos apnum:Size)">: ")))
  (if(null apnum:Size)(setq apnum:Size oldSize))
  (if apnum:Block(setq oldBlock apnum:Block))
  (setq temBl
     (entsel(strcat "\nSelect block <"
         (if apnum:Block apnum:Block "not difined") "> > "))); end setq
  (cond
    ((and apnum:Block(not temBl)(tblsearch "BLOCK" apnum:Block))
    (setq apnum:Block oldBlock)
     ); end condition #1
    ((= 1 (cdr(assoc 66(entget(car temBl)))))
    (setq apnum:Block(cdr(assoc 2(entget(car temBl)))))
    ); end condition #2
    (t
     (princ "\nBlock not contains attribute! ")
     (setq apnum:Block nil)
     ); end condition #3
    ); end cond
  (if apnum:Block
    (progn
      (princ "\n>>> Pick insertion point or press Esc to quit <<<\n ")
(while T
  (command "_-insert" apnum:Block "_s" apnum:Size pause "0"
       (strcat apnum:Pref(itoa apnum:Num)apnum:Suf)); end command
    (setq apnum:Num (1+ apnum:Num))
  ); end while
); end progn
    ); end if
  (setvar "ATTDIA" att)
  (princ)
  ); end of c:apnum
  (princ "\nType in command line:")
(princ "\n\t Num - Insert text with increment value")
(princ "\n\t Renum - Renumbering text in DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE")
(princ "\n\t TTC - Text to Text copy. Copy text from DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one")
(princ "\n\t Apnum - for numbering by blocks with single attribute")

(command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"")

  (vla-put-Alignment newNum acAlignmentMiddleCenter)

Alignment
acAlignment enum; read-write
acAlignmentLeft
acAlignmentCenter
acAlignmentRight
acAlignmentAligned
acAlignmentMiddle
acAlignmentFit
acAlignmentTopLeft
acAlignmentTopCenter
acAlignmentTopRight
acAlignmentMiddleLeft
acAlignmentMiddleCenter
acAlignmentMiddleRight
acAlignmentBottomLeft
acAlignmentBottomCenter
acAlignmentBottomRight

(defun c:numm1 (/ oldPref oldSuf oldStart curStr newNum
           actDoc actSp oldEcho oldSize *error*)
  (defun *error* (msg)
    (setvar "CMDECHO" oldEcho)
    (princ)
    ); end *error*
  (vl-load-com)
  (if(not num:Size)(setq num:Size(getvar "DIMTXT")))
  (if(not num:Pref)(setq num:Pref ""))
  (if(not num:Suf)(setq num:Suf ""))
  (if(not num:Num)(setq num:Num 1))
  (setq oldPref num:Pref
        oldSuf num:Suf
        oldStart num:Num
   oldSize num:Size
   actDoc(vla-get-ActiveDocument
      (vlax-get-acad-object))
   oldEcho(getvar "CMDECHO")
   ); end setq
  (setvar "CMDECHO" 0)
  (if(= (vla-get-ActiveSpace actDoc) 1)
    (setq actSp(vla-get-ModelSpace actDoc))
    (setq actSp(vla-get-PaperSpace actDoc))
    ); end setq
  (setq num:Size
    (getreal
      (strcat "\nSpecify text size <"(rtos num:Size)">: ")))
  (if(null num:Size)(setq num:Size oldSize))
  (setq num:Pref
    (getstring T
      (strcat "\nType prefix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Pref"> :")))
  (if(= "" num:Pref)(setq num:Pref oldPref))
  (if(= " " num:Pref)(setq num:Pref ""))
  (setq num:Suf
    (getstring T
      (strcat "\nType suffix:(If you want to delete prefix type ' ' (press SPACE key on keyboard) <"num:Suf"> :")))
  (if(= "" num:Suf)(setq num:Suf oldSuf))
  (if(= " " num:Suf)(setq num:Suf ""))
;;;=============================================================================
;;; Степень \A1;12{\H0.7x;\S23^;}                                            ;_=
(if (/= num:Suf "")(setq num:Suf (strcat  "{\\A1;\\H0.7x;\\S" num:Suf ";}")));_=
;;;=============================================================================
  (setq num:Num
    (getint
      (strcat "\nEnter start number <"(itoa num:Num)">: ")))
  (if(null num:Num)(setq num:Num oldStart))
(while T
  (setq curStr(strcat num:Pref(itoa num:Num)num:Suf)
        newNum(vla-AddMText actSp
         (vlax-3d-point '(0.0 0.0 0.0)) 0 curStr))
  (vla-put-height newNum num:Size)
  (vla-put-AttachmentPoint newNum acAttachmentPointMiddleCenter)
  (vla-put-InsertionPoint newNum (vlax-3d-point '(0.0 0.0 0.0)))
  (command "_.copybase"(trans '(0.0 0.0 0.0)0 1)(entlast)"")
  (command "_.erase" (entlast) "")
  (command "_.pasteclip" pause)
    (setq num:Num(1+ num:Num))
  ); end while
  (princ)
  )