请高手帮忙写个更改编号（自动相加工具）

lxy_2080

原编号:号码 china-001"2/22"  号码 china-001"1/33"  号码 china-001"1/22"  号码 china-001"3/22"  号码 china-001"5/22"  号码 china-001"2/22"  号码 china-001"2/22".
新编号:号码 china-001"1/22"   号码 china-001"2/22"  号码 china-001"3/22"   号码 china-001"4/22"  号码 china-001"5/22"  号码 china-001"6/22"  号码 china-001"7/22".

要求:新的编号刷时,只更改""""里面的数字,22是要求输入的数字,在新编号中不进行增减,1/2/3/4/等,要求输入下第一个数字,后面自动相加.(字体\字号保持原来不变)

最好能批量选取(更改顺序是从左至右、从上至下)及一个一个的选。

caiqs

lxy_2080 发表于 2014-2-22 10:42
忘传附件了。哈哈。钱不多，表个心意。望高手给予帮助

(defun c:subno (/ ss no1 no2 entlst sortlst newno1 newno2)
  (defun Ss->Lst (ss)
    (vl-remove-if-not
      '(lambda (x) (= (type x) 'ENAME))
      (apply 'append (ssnamex ss))
    )
  ) ;_选择集变表

  (defun strcut        (str / start asclst revstr end newlst i sumlen)
    (setq start (VL-STRING-SEARCH "\"" str))
    (setq asclst (VL-STRING->LIST str))
    (setq revstr (VL-LIST->STRING (REVERSE asclst)))
    (setq sumlen (strlen str))
    (setq end (vl-string-search "\"" revstr))
    (setq end (- sumlen end))
    (setq newlst nil)
    (setq i start)
    (repeat (- end start)
      (setq newlst (cons (nth i asclst) newlst))
      (setq i (1+ i))
    )
    (VL-LIST->STRING (REVERSE newlst))
  ) ;_剪取双引号中的文字
  (while t
  (princ "\n选择文字：")
  (setq        ss (VL-CATCH-ALL-APPLY
             'ssget
             (list (list (cons 0 "*text") (cons 1 "*\"*/*\"*")))
           )
  )
  (if (or (null ss) (VL-CATCH-ALL-ERROR-P ss))
    (VL-EXIT-WITH-ERROR 0)
  )
  (initget 5)
  (setq NO1 (VL-CATCH-ALL-APPLY 'getint '("\n输入递增序号:")))
  (if (VL-CATCH-ALL-ERROR-P NO1)
    (progn (princ "*取消*") (VL-EXIT-WITH-ERROR 1))
  )
  (setq NO2 (VL-CATCH-ALL-APPLY 'getstring '("\n输入固定编号:")))
  (if (or (VL-CATCH-ALL-ERROR-P NO2)
          (= (strlen (vl-string-trim " " No2)) 0)
      )
    (progn (princ "*取消*") (VL-EXIT-WITH-ERROR 1))
  )
  (setq entlst (ss->lst ss))
  (setq
    sortlst (vl-sort
              entlst
              '(lambda
                 (txta txtb / txtadat txtbdat inspa inspb x1 x2 y1 y2)
                  (setq txtAdat (entget txta))
                  (setq txtbdat (entget txtb))
                  (setq inspA (cdr (assoc 10 txtadat)))
                  (setq inspb (cdr (assoc 10 txtbdat)))
                  (setq        x1 (car inspa)
                        x2 (car inspb)
                        y1 (cadr inspa)
                        y2 (cadr inspb)
                  )
                  (if (= x1 x2)
                    (<= Y1 y2)
                    (<= x1 x2)
                  )

               )
            )
  ) ;_按位置排序
  (setq newNO1 no1)
  (setq newNO2 NO2)
  (mapcar
    '(lambda (txt / txtdat txtstr newno willcutstr newstr newtxtdat)
       (setq txtdat (entget txt))
       (setq txtstr (cdr (assoc 1 txtdat)))
       (setq newNO (strcat "\"" (itoa newno1) "/" newNO2 "\""))
       (setq willcutstr (strcut txtstr))
       (setq newstr (vl-string-subst newno willcutstr txtstr))
       (setq newtxtdat (subst (cons 1 newstr) (assoc 1 txtdat) txtdat))
       (entmod newtxtdat)
       (entupd txt)
       (setq newNO1 (1+ newNo1)) ;_编号递增
     )
    sortlst
  ) ;_批量替换
    )
  (princ)
)

lxy_2080

忘传附件了。哈哈。钱不多，表个心意。望高手给予帮助