请教编号的递增递减控制

xj6019

从论坛里拼凑修剪来的代码，批量生成多段线编号，怎么可以控制标记文字的递增顺序呀，比如说沿着X轴递增或递减，沿着Y轴递增或递减。
现在的代码好像有时候按顺序，有时候又不按数序，没有固定的规律，望老师们帮实现一下。

(defun C:NM (/ ss font_height1 n k po na)
    (setq font_height 100)
  (if (and (setq ss (ssget (list '(0 . "LWPOLYLINE")) )))
      )
          
    (progn
      (setq n 0
            k 1
      )
      (repeat (sslength ss)
        (setq na (ssname ss n))
        (setq po (Get_center_relative na))
       
(entmake (list '(0 . "TEXT")
                       (cons 1 (rtos k 2 0))
                       (cons 10 po)
                       (cons 40 font_height)
                            )
               
        )
        (setq k (1+ k))
        (setq n (1+ n))
      )
    )
  )

xj6019

贴个图看看效果

xj6019

(DEFUN C:NM ()
(setq en(entlast))
(BHDXANSHUNX)
(setq ssn (fy_sslast en))
(sssetfirst nil SSN)
(chhangWZJDXJ)
(sssetfirst nil SSN)
(GWZTIANJQZHUITYY)
(sssetfirst nil SSN)
(WZJZZSFLJLA)
)

;;;;;改变文字角度代码
(DEFUN chhangWZJDXJ ()
(setq s (ssget))
(setq hig 90);;改变文字角度  90
(if (= hig nil) (setq hig 0.0))
(setq hig (* pi hig) hig (/ hig 180.0))
(setq h50 (cons 50 hig))
(setq n (sslength s))
(setq k 0 )
(while (< k n)
      (setq name (ssname s k))
      (setq a (entget name))
      (setq b (assoc '0 a))
      (setq b (cdr b))
      (if (= b "TEXT")(progn
        (setq h (assoc '50 a))
        (setq a (subst h50 h a))
        (entmod a)
        ))
      (setq k (+ k 1))
)
)
;;;;生成编号文字
(defun BHDXANSHUNX (/ ss font_height1 n k po na)
    (setq font_height 100)
  (if (and (setq ss (ssget (list '(0 . "LWPOLYLINE,region,circle"))))
      )
         
    (progn
      (setq n 0
            k 1
      )
      (repeat (sslength ss)
        (setq na (ssname ss n))
        (setq po (Get_center_relative na))
        
(entmake (list '(0 . "TEXT")
                       (cons 1 (rtos k 2 0))
                       (cons 10 po)
                       (cons 40 font_height)
                            )
               
        )
        (setq k (1+ k))
        (setq n (1+ n))
      )
    )

  )
  (princ)
)
;;;;;;添加文字前后缀代码
(DEFUN GWZTIANJQZHUI()
(setq qh 1);;;1 前缀 2后缀
(setq s (ssget))
(setq str (getstring "\n输入前后缀文字:"))
(setq n (sslength s))
(setq k 0 )
(while (< k n)
      (setq name (ssname s k))
      (setq a (entget name))
      (setq t1 (assoc '0 a))
      (setq t1 (cdr t1))
      (if (= t1 "TEXT") (PROGN
        (setq h (assoc '1 a))
        (setq hh (cdr h))
        (if (= qh 1)(setq  str1 (strcat str hh)))
        (if (/= qh 1)(setq str1 (strcat hh str)))
        (setq h1 (cons 1 str1))
        ;(if (= str "") (setq h1 h))
        (setq a (subst h1 h a))
        (entmod a)
        ))
      (setq k (+ k 1))
)
)


(defun Get_center_relative (ename   /            Pts            2R            Mk
                            Mkline  points  DelLine Tssred  i
                            lst            N            Newlst  DistList
                            R            Number  Tssbak  TssSub  Pt
                           )
  (setq        Obj    (Vlax-Ename->Vla-Object ename)
        Tssbak (Vlax-Get Obj 'Thickness)
        TssSub (Vlax-Put Obj 'Thickness 0)
  )
  (setq        Pts        (GetBoundingBox ename)
        2R        (MJ:MIDPOINT (CAR Pts) (CADR Pts))
        Mk        (entmake (list (cons 0 "LINE")
                               (cons 8 "JMDSS")
                               (cons 10 (polar 2R 0.0 1000))
                               (cons 11 (polar 2R 3.14159 1000))
                         )
                )
        Mkline        (entlast)
        points        (vlax-invoke
                  (vlax-ename->vla-object ename)
                  'IntersectWith
                  (vlax-ename->vla-object Mkline)
                  acExtendOtherEntity
                )
        Tssred        (Vlax-Put Obj 'Thickness (eval Tssbak))
        DelLine        (entdel Mkline)
        i        0
        lst        nil
  )
  (repeat (/ (length points) 3)
    (setq lst (append lst
                      (list (list (nth i points)
                                  (nth (1+ i) points)
                                  (nth (+ 2 i) points)
                            )
                      )
              )
    )
    (setq i (+ i 3))
  )
  (setq lst (px lst))
  (if (>= (length lst) 4)
    (progn
      (setq N 0
            Newlst nil
      )
      (repeat (/ (length lst) 2)
        (setq
          Newlst (append Newlst
                         (list (list (nth N lst) (nth (1+ N) lst)))
                 )
        )
        (setq N (+ 2 N))
      )
      (setq DistList nil
            R 0
      )
      (repeat (length Newlst)
        (setq Number   (nth R Newlst)
              DistList (append DistList
                               (list (distance (car Number) (cadr Number)))
                       )
        )
        (setq R (1+ R))
      )
      (setq Pt (nth (vl-position (car (vl-sort DistList '>)) DistList)
                    Newlst
               )
      )
      (MJ:MIDPOINT (car pt) (cadr pt))        ;返回?
    )
    (MJ:MIDPOINT (car lst) (cadr lst))        ;返回?
  )
)

(defun MJ:MIDPOINT (P1 P2)
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) P1 P2)
)

(defun GetBoundingBox (ent / ll ur)
  (vla-getboundingbox (vlax-ename->vla-object ent) 'll 'ur)
  (mapcar 'vlax-safearray->list (list ll ur))
)

(defun px (X)
  (vl-sort X
           (function (lambda (e1 e2)
                       (< (car e1) (car e2))
                     )
           )
  )
)


;;程序来源于LLXXZZ大?
;;;http://bbs.mjtd.com/thread-89140-1-1.html
(defun GWZTIANJQZHUITYY (/  SS    SSLIST   index  INDEX0    SSLIST-PTL
        TMP-PT  XZ_SORTLIST      ENTLIST   N
        ED
       )
           ;(C:CNM001xxx)
          ;(C:C88)
            (setvar "CMDECHO" 0)

  (setq ss (ssget '((0 . "TEXT"))))
(setq str (getstring "\n输入前后缀文字:"))
;_选择集=>图元列表
  (setq sslist (ss2list ss) )

;_开始构建图元点位表

(setq index (sslength ss) );

  (setq index0 0
sslist-ptl
  '()
tmp-pt '()
  )
  (repeat index
    (setq tmp-pt
    (cons
      (nth index0 sslist)
      (cons (cdr (assoc 10 (entget (nth index0 sslist)))) tmp-pt)
    )
    )
    (setq sslist-ptl (cons tmp-pt sslist-ptl))
    (setq tmp-pt '())
    (setq index0 (1+ index0))
  )
;_从左到右从上到下
  
  (setq XZ_sortlist
  (vl-sort
    (vl-sort sslist-ptl
      '(lambda (s1 s2) (> (cadadr s1) (cadadr s2)))   ;< 从右向左递增  >从左向右递增  对应改变大小号就能实现 递增方向的切换
    )
    '(lambda (s3 s4)
       (if (equal (cadadr s3) (cadadr s4) 0.6)
  (>(caadr s3) (caadr s4))
       )
     )
  )  
  )
  
  (setq entlistXX (mapcar '(lambda (x) (car x)) XZ_sortlist))
  
(setq entlist(HH:ssPts:Sort  entlistXX   "X" 1  ))
;_更新文本数据
  (setq n 1)
  (mapcar '(lambda (x)
      (setq ed (entget x))
      (setq ed (subst (cons 1 (strcat str (VL-PRINC-TO-STRING n)))  ;HJ-是编号的前缀  也可以不加前缀  就从1开始追个递增 左---右，上---下
        (assoc 1 ed)
        ed
        )
      )
      (setq n (1+ n))
      (entmod ed)
    )
   entlist
  )
  (princ)
(setq enX(entlast))
  (princ)
)

;;选择集转为图元列表
(defun ss2list ( ss / n i elist )
(cond
  ((null ss) NIL)
  ((= (type ss) 'Pickset)
   (setq n  (sslength ss)
     i n
     elist '()
   )
   (repeat n
    (setq i (1- i))
    ;;如果没有这个if，那么选择集中被删除的图元，也会被加入到列表之中????但是极其偶尔也有可能，图元不存在但是能entget（遇到过一次，原因不明，或许是CAD的BUG）
    (if (entget (ssname ss i))
     (setq elist (cons (ssname ss i) elist))
    )
   )
   elist
  )
  ((= (type ss) 'ename)
   (list ss)
  )
  ((= (type ss) 'list)
   (vl-remove-if-not ''((x) (and (= (type x) 'ename) (entget x))) ss)
  )
  ( T NIL )
)
)



(defun WZJZZSFLJLA(/ box en_tmp ent i pt0 pt1 ss tmp)
        (setvar "CMDECHO" 0)
        (vl-load-com)
        (if (setq ss (ssget))
                (progn
                        (defun box(e / ll ur)
                                (vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
                                (mapcar 'vlax-safearray->list (list ll ur))
                        )
                        (setq i -1)
                        (command "undo" "be")
                        (while (setq ent (ssname ss (setq i (1+ i))))
                                (setq tmp (box ent))
                                (setq tmp (mapcar '+ (car tmp) (cadr tmp)))
                                (setq pt0 (mapcar '* tmp '(0.5 0.5 0.5)))
                                (entdel ent)
                                (setq en_tmp (bpoly pt0))
                                (entdel ent)
                                (setq tmp (box en_tmp))
                                (setq tmp (mapcar '+ (car tmp) (cadr tmp)))
                                (setq pt1 (mapcar '* tmp '(0.5 0.5 0.5)))
                                (command "move" ent "" "non" pt0 "non" pt1)
                                (entdel en_tmp)
                        )
                        (command "undo" "e")
                )
                (princ "\n没有选择对象！")
        )
        (princ)
)以下是黄老师的函数
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108678&highlight=%C5%C5%D0%F2
;;ssPts: 1 选择集，返回图元列表
;;           2 点表(1到n维 1维时key只能是x或X)，返回点表
;;          3 图元列表，返回图元列表
;;Key: "xyzXYZ"任意组合,例如"yX",y在前表示y坐标优先，小y表示从小到大(注:二维点时，不能有z)
;;FUZZ: 允许误差
;;注:点表可以1到n维混合,Key长度不大于点的最小维数。
;;示例1 (HH:ssPts:Sort (ssget) "YxZ" 0.5);返回(<Entity name: 7ef7b3a8> <Entity name: 7ef7b3a0>)
;;示例2 (HH:ssPts:Sort (list '(2 3) '(3 5)) "Yx" 0.5);返回((3 5) (2 3))
;;示例3 (HH:ssPts:Sort '(<Entity name: 7ef79a28> <Entity name: 7ef79a10>) "YxZ" 0.5)
;;示例4 (HH:ssPts:Sort (list "DF" "ZX" "A" "DD" "A") "X" 1)=>("ZX" "DF" "DD" "A" "A")
;;示例5 (HH:ssPts:Sort (list 5 8 5 9) "X" 1)=>(9 8 5)
;;本程序是在fsxm的扩展 自贡?明儒 2014年3月22日
(defun HH:ssPts:Sort (ssPts KEY FUZZ / E EN FUN LST N)
  ;;1 点列表排序
  (defun sortpts (PTS FUN xyz FUZZ)
    (vl-sort pts
             '(lambda (a b)
                (if (not (equal (xyz a) (xyz b) fuzz))
                  (fun (xyz a) (xyz b))
                )
              )
    )
  )
  ;;2 排序
  (defun sortpts1 (PTS KEY FUZZ)
    (setq Key (vl-string->list Key))
    (foreach xyz (reverse Key)
      (cond ((< xyz 100)
             (setq fun >)
             (setq xyz (nth (- xyz 88) (list car cadr caddr)))
            )
            (T
             (setq fun <)
             (setq xyz (nth (- xyz 120) (list car cadr caddr)))
            )
      )
      (setq Pts (sortpts Pts fun xyz fuzz))
    )
  )
  ;;3 本程序主程序
  (cond
    ((= (type ssPts) 'PICKSET)
     (repeat (setq n (sslength ssPts))
       (if (and        (setq e (ssname ssPts (setq n (1- n))))
                (setq en (entget e))
           )
         (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
       )
     )
     (mapcar 'last (sortpts1 lst KEY FUZZ))
    )
    ((Listp ssPts)
      (cond
        ((vl-consp (car ssPts)) (sortpts1 ssPts KEY FUZZ))
        ((= (type (car ssPts)) 'ENAME)
         (foreach e ssPts
           (if (setq en (entget e))
             (setq lst (cons (append (cdr (assoc 10 en)) (list e)) lst))
           )
         )
         (mapcar 'last (sortpts1 lst KEY FUZZ))
        )
        (T
         (cond ((equal key "X") (vl-sort ssPts '>))
               (T (vl-sort ssPts '<))
         )
        )
      )
    )   
  )
)

xj6019

不知道你们能运行起来了不，我这里目前电脑情绪还算稳定，说一下这一圈咋转的哦，框选多段线在各自的中心先生成一个数字，然后用代码给文字转动一个角度，上面是转了90度。因为生成的代码文字是左对齐，因此文字看着有些偏，然后给这些文字加个前缀后重新排序，搞了两天，最终还是用上了黄老师的代码后，才算正常，特此感谢，然后再把这组生成的文字进行中心对齐，嘿嘿嘿，无奈，暂时就只会这么拼一下用了，老师有好的方法可以实现的话，请不吝赐教呀。

cghdy

可以先加入点表，并对其排序

xj6019

给你们欣赏一下脑瓜子不够的人，为了实现一个功能，绕可能至少7852个圈后的成果

xj6019

代码乱七八糟，丢人显眼啦，甚至在老师们眼里基本算的上是垃圾代码，没法，虽然乱，但是可以解决我目前遇到的批量编号的问题了，存上论坛，当个记事本备份一下自己的思路，仅此而已，也希望其他老师看到，能提供一个更好用的更简洁的代码。

start4444

绕圈的过程就是学习的过程

999999

xj6019 发表于 2020-11-30 21:41
贴个图看看效果

请问您用的是什么软件编的

czb203

可以先加入点表，并对其排序