[悬10币求]如何求出多个带分隔符字符串每段的最大值并返回带分隔符最大字符串（具体详

x_s_s_1

cabinsummer 发表于 2011-10-30 17:12
任意分割字符串函数

这样你也就可以一次将"13-0-6"分割为("13" "0" "6")了，祝楼主好运

谢谢您的函数，我前面找了飞诗的

2. ;; ! ***************************************************************************
   
3. ;; ! Fsxm-Split
   
4. ;; ! ***************************************************************************
   
5. ;; ! 功  能  : 用指定的分隔符对字符串分段提取字符.
   
6. ;; ! 参  数  : string字符串，strkey分隔符。
   
7. ;; ! 返回值  : 字符串表
   
8. ;; ! 说  明  : 适用 AutoCAD 2000+
   
9. ;; ! from    : fsxm
   
10. ;; ! Web     : http://bbs.mjtd.com/thread-89969-1-5.html
    
11. ;; ! ****************************************************************************
    
12. (defun Fsxm-Split (string strkey / po strlst xlen)
    
13.   (setq xlen (1+ (strlen strkey)))
    
14.   (while (setq po (vl-string-search strkey string))
    
15.     (setq strlst (cons (substr string 1 po) strlst))
    
16.     (setq string (substr string (+ po xlen)))
    
17.   ) ;_ 结束while
    
18.   (reverse (cons string strlst))
    
19. ) ;_ 结束defun

;; ! ***************************************************************************<br /> ;; ! Fsxm-Split<br /> ;; ! ***************************************************************************<br /> ;; ! 功  能  : 用指定的分隔符对字符串分段提取字符.<br /> ;; ! 参  数  : string字符串，strkey分隔符。<br /> ;; ! 返回值  : 字符串表<br /> ;; ! 说  明  : 适用 AutoCAD 2000+<br /> ;; ! from    : fsxm <br /> ;; ! Web     : http://bbs.mjtd.com/thread-89969-1-5.html<br /> ;; ! ****************************************************************************<br /> (defun Fsxm-Split (string strkey / po strlst xlen)<br />   (setq xlen (1+ (strlen strkey)))<br />   (while (setq po (vl-string-search strkey string))<br />     (setq strlst (cons (substr string 1 po) strlst))<br />     (setq string (substr string (+ po xlen)))<br />   ) ;_ 结束while<br />   (reverse (cons string strlst))<br /> ) ;_ 结束defun

yjr111

给楼主整了一个，看看行不？（对10以上数字排序还没处理，如“2”和“12”，2会在前滴）

飞诗(fsxm)

很好的练习题哦,
技巧性较强
有空的童鞋可以试试玩！

x_s_s_1

飞诗(fsxm) 发表于 2011-10-31 09:48
很好的练习题哦,
技巧性较强
有空的童鞋可以试试玩！

谢谢飞版主的关注

yjr111

貌似已经解决了楼主的问题。。。。。

飞诗(fsxm)

我也过来练练手哦！
先占下本楼备用！
下班后上传程序！
玩这个的确还是要些技巧的,嘿嘿

OK ,请测试一下哈！程序命令是：Test
源程序帖在50楼！

x_s_s_1

飞诗(fsxm) 发表于 2011-10-31 20:03
我也过来练练手哦！
先占下本楼备用！
下班后上传程序！

我先把文字挪到了一起，然后justifytext
写到这里

2. 
   
3. 
   
4. ;; ! ***************************************************************************
   
5. ;; ! Fsxm-Split
   
6. ;; ! ***************************************************************************
   
7. ;; ! 功  能  : 用指定的分隔符对字符串分段提取字符.
   
8. ;; ! 参  数  : string字符串，strkey分隔符。
   
9. ;; ! 返回值  : 字符串表
   
10. ;; ! 说  明  : 适用 AutoCAD 2000+
    
11. ;; ! from    : fsxm
    
12. ;; ! Web     : http://bbs.mjtd.com/thread-89969-1-5.html
    
13. ;; ! ****************************************************************************
    
14. (defun Fsxm-Split (string strkey / po strlst xlen)
    
15.   (setq xlen (1+ (strlen strkey)))
    
16.   (while (setq po (vl-string-search strkey string))
    
17.     (setq strlst (cons (substr string 1 po) strlst))
    
18.     (setq string (substr string (+ po xlen)))
    
19.   ) ;_ 结束while
    
20.   (reverse (cons string strlst))
    
21. ) ;_ 结束defun
    
22. ;; ! ***************************************************************************
    
23. ;; ! makelsp
    
24. ;; ! ***************************************************************************
    
25. ;; ! 功  能  : 根据特征组码分类列表.
    
26. ;; ! 参  数  : SS选折集，bk特征组码。
    
27. ;; ! 返回值  : 特征组码值与图元名表
    
28. ;; ! 说  明  : 适用 AutoCAD 2000+
    
29. ;; ! from    : 龙龙仔
    
30. ;; ! Web     : http://bbs.mjtd.com/forum.php?mod=viewthread&tid=45690
    
31. ;; ! ****************************************************************************
    
32. (defun makelsp (ss BK / ENT LST1 LST2 LST3 N NAME)
    
33.   (setq N 0)
    
34.   (if ss
    
35.     (progn
    
36.       (repeat (sslength SS)
    
37. (setq ENT (ssname SS N))
    
38. (if (setq LST3
    
39.      (assoc (setq NAME (cdr (assoc BK (entget ENt)))) LST2)
    
40.      ) ;_ 结束setq
    
41.    (progn
    
42.      (setq LST1 (append LST3 (list (CDR (assoc 1 (entget ENt))))))
    
43.      (setq LST2 (subst LST1 LST3 LST2))
    
44.    ) ;_ 结束progn
    
45.    (setq LST2 (cons (list NAME (CDR (assoc 1 (entget ENt)))) LST2))
    
46. ) ;_ 结束if
    
47. (setq N (1+ N))
    
48.       ) ;_ 结束repeat
    
49.     ) ;_ 结束progn
    
50.   ) ;_ 结束if
    
51.   LST2
    
52. ) ;_ 结束defun
    
53. (setq ss(ssget  "x" '((0 . "TEXT"))));构造针对TEXT的选择集
    
54. (command "justifytext " ss "" "c" "")
    
55. (SETQ LST (makelsp ss 11))
    
56. ;|这里还没想好循环
    
57. (setq n (length lst))
    
58. (setq lstt (nth 1 lst))
    
59. (setq bb(mapcar '(lambda (x) (Fsxm-Split x "-")) (cdr lstt)))
    
60. |;
    
61. ;;;G字头判断
    
62. (defun for-g (bb /)
    
63.   (strcat
    
64.     "G"
    
65.     (rtos
    
66.       (eval
    
67.         (cons
    
68.           'max
    
69.           (mapcar 'atof
    
70.                   (mapcar '(lambda (x) (vl-string-left-trim "G" x))
    
71.                           (CAR (apply 'mapcar (cons 'list bb)))
    
72.                   ) ;_ 结束mapcar
    
73.           ) ;_ 结束mapcar
    
74.         ) ;_ 结束cons
    
75.       ) ;_ 结束eval
    
76.       2
    
77.       1
    
78.     ) ;_ 结束rtos
    
79.     "-"
    
80.     (rtos (eval
    
81.             (cons 'max
    
82.                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))
    
83.             ) ;_ 结束cons
    
84.           ) ;_ 结束eval
    
85.           2
    
86.           1
    
87.     ) ;_ 结束rtos
    
88.   ) ;_ 结束strcat
    
89. ) ;_ 结束defun
    
90. ;;;VT字头判断
    
91. (defun for-VT (bb /)
    
92.   (strcat
    
93.     "VT"
    
94.     (rtos
    
95.       (eval
    
96.         (cons
    
97.           'max
    
98.           (mapcar 'atof
    
99.                   (mapcar '(lambda (x) (vl-string-left-trim "VT" x))
    
100.                           (CAR (apply 'mapcar (cons 'list bb)))
     
101.                   ) ;_ 结束mapcar
     
102.           ) ;_ 结束mapcar
     
103.         ) ;_ 结束cons
     
104.       ) ;_ 结束eval
     
105.       2
     
106.       1
     
107.     ) ;_ 结束rtos
     
108.     "-"
     
109.     (rtos (eval
     
110.             (cons 'max
     
111.                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))
     
112.             ) ;_ 结束cons
     
113.           ) ;_ 结束eval
     
114.           2
     
115.           1
     
116.     ) ;_ 结束rtos
     
117.   ) ;_ 结束strcat
     
118. ) ;_ 结束defun
     
119. ;;;无字头判断
     
120. (defun for-pj (bb /)
     
121.   (strcat
     
122.     (rtos (eval
     
123.             (cons 'max
     
124.                   (mapcar 'atof (CAR (apply 'mapcar (cons 'list bb))))
     
125.             ) ;_ 结束cons
     
126.           ) ;_ 结束eval
     
127.           2
     
128.           1
     
129.     ) ;_ 结束rtos
     
130.     "-"
     
131.     (rtos (eval
     
132.             (cons 'max
     
133.                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))
     
134.             ) ;_ 结束cons
     
135.           ) ;_ 结束eval
     
136.           2
     
137.           1
     
138.     ) ;_ 结束rtos
     
139.     "-"
     
140.     (rtos (eval
     
141.             (cons 'max
     
142.                   (mapcar 'atof (CADdR (apply 'mapcar (cons 'list bb))))
     
143.             ) ;_ 结束cons
     
144.           ) ;_ 结束eval
     
145.           2
     
146.           1
     
147.     ) ;_ 结束rtos
     
148.   ) ;_ 结束strcat
     
149. ) ;_ 结束defun
     

<br /> <br /> ;; ! ***************************************************************************<br /> ;; ! Fsxm-Split<br /> ;; ! ***************************************************************************<br /> ;; ! 功  能  : 用指定的分隔符对字符串分段提取字符.<br /> ;; ! 参  数  : string字符串，strkey分隔符。<br /> ;; ! 返回值  : 字符串表<br /> ;; ! 说  明  : 适用 AutoCAD 2000+<br /> ;; ! from    : fsxm <br /> ;; ! Web     : http://bbs.mjtd.com/thread-89969-1-5.html<br /> ;; ! ****************************************************************************<br /> (defun Fsxm-Split (string strkey / po strlst xlen)<br />   (setq xlen (1+ (strlen strkey)))<br />   (while (setq po (vl-string-search strkey string))<br />     (setq strlst (cons (substr string 1 po) strlst))<br />     (setq string (substr string (+ po xlen)))<br />   ) ;_ 结束while<br />   (reverse (cons string strlst))<br /> ) ;_ 结束defun<br /> ;; ! ***************************************************************************<br /> ;; ! makelsp<br /> ;; ! ***************************************************************************<br /> ;; ! 功  能  : 根据特征组码分类列表.<br /> ;; ! 参  数  : SS选折集，bk特征组码。<br /> ;; ! 返回值  : 特征组码值与图元名表<br /> ;; ! 说  明  : 适用 AutoCAD 2000+<br /> ;; ! from    : 龙龙仔 <br /> ;; ! Web     : http://bbs.mjtd.com/forum.php?mod=viewthread&tid=45690<br /> ;; ! ****************************************************************************<br /> (defun makelsp (ss BK / ENT LST1 LST2 LST3 N NAME)<br />   (setq N 0)<br />   (if ss<br />     (progn<br />       (repeat (sslength SS)<br /> (setq ENT (ssname SS N))<br /> (if (setq LST3<br />      (assoc (setq NAME (cdr (assoc BK (entget ENt)))) LST2)<br />      ) ;_ 结束setq<br />    (progn<br />      (setq LST1 (append LST3 (list (CDR (assoc 1 (entget ENt))))))<br />      (setq LST2 (subst LST1 LST3 LST2))<br />    ) ;_ 结束progn<br />    (setq LST2 (cons (list NAME (CDR (assoc 1 (entget ENt)))) LST2))<br /> ) ;_ 结束if<br /> (setq N (1+ N))<br />       ) ;_ 结束repeat<br />     ) ;_ 结束progn<br />   ) ;_ 结束if<br />   LST2<br /> ) ;_ 结束defun<br /> (setq ss(ssget  "x" '((0 . "TEXT"))));构造针对TEXT的选择集<br /> (command "justifytext " ss "" "c" "")<br /> (SETQ LST (makelsp ss 11))<br /> ;|这里还没想好循环<br /> (setq n (length lst))<br /> (setq lstt (nth 1 lst))<br /> (setq bb(mapcar '(lambda (x) (Fsxm-Split x "-")) (cdr lstt)))<br /> |;<br /> ;;;G字头判断<br /> (defun for-g (bb /)<br />   (strcat<br />     "G"<br />     (rtos<br />       (eval<br />         (cons<br />           'max<br />           (mapcar 'atof<br />                   (mapcar '(lambda (x) (vl-string-left-trim "G" x))<br />                           (CAR (apply 'mapcar (cons 'list bb)))<br />                   ) ;_ 结束mapcar<br />           ) ;_ 结束mapcar<br />         ) ;_ 结束cons<br />       ) ;_ 结束eval<br />       2<br />       1<br />     ) ;_ 结束rtos<br />     "-"<br />     (rtos (eval<br />             (cons 'max<br />                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))<br />             ) ;_ 结束cons<br />           ) ;_ 结束eval<br />           2<br />           1<br />     ) ;_ 结束rtos<br />   ) ;_ 结束strcat<br /> ) ;_ 结束defun<br /> ;;;VT字头判断<br /> (defun for-VT (bb /)<br />   (strcat<br />     "VT"<br />     (rtos<br />       (eval<br />         (cons<br />           'max<br />           (mapcar 'atof<br />                   (mapcar '(lambda (x) (vl-string-left-trim "VT" x))<br />                           (CAR (apply 'mapcar (cons 'list bb)))<br />                   ) ;_ 结束mapcar<br />           ) ;_ 结束mapcar<br />         ) ;_ 结束cons<br />       ) ;_ 结束eval<br />       2<br />       1<br />     ) ;_ 结束rtos<br />     "-"<br />     (rtos (eval<br />             (cons 'max<br />                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))<br />             ) ;_ 结束cons<br />           ) ;_ 结束eval<br />           2<br />           1<br />     ) ;_ 结束rtos<br />   ) ;_ 结束strcat<br /> ) ;_ 结束defun<br /> ;;;无字头判断<br /> (defun for-pj (bb /)<br />   (strcat<br />     (rtos (eval<br />             (cons 'max<br />                   (mapcar 'atof (CAR (apply 'mapcar (cons 'list bb))))<br />             ) ;_ 结束cons<br />           ) ;_ 结束eval<br />           2<br />           1<br />     ) ;_ 结束rtos<br />     "-"<br />     (rtos (eval<br />             (cons 'max<br />                   (mapcar 'atof (CADR (apply 'mapcar (cons 'list bb))))<br />             ) ;_ 结束cons<br />           ) ;_ 结束eval<br />           2<br />           1<br />     ) ;_ 结束rtos<br />     "-"<br />     (rtos (eval<br />             (cons 'max<br />                   (mapcar 'atof (CADdR (apply 'mapcar (cons 'list bb))))<br />             ) ;_ 结束cons<br />           ) ;_ 结束eval<br />           2<br />           1<br />     ) ;_ 结束rtos<br />   ) ;_ 结束strcat<br /> ) ;_ 结束defun<br />

x_s_s_1

飞诗(fsxm) 发表于 2011-10-31 20:03
我也过来练练手哦！
先占下本楼备用！
下班后上传程序！

飞版，1827个对象的时候就比较慢了

yjr111

源程序上传，没必要自己留着，就怕自己写得不好，所以不好意思拿出来。。。

2. ;;;;;;;;;;;;;找出各组对应位置最大值 BY YJR111 2011-10-30;;;;;;;;;;;;;;;;;;;;;;;
   
3. 
   
4. (DEFUN c:findmaxnum(/ nn mm ss n ss0 pt0 lst ssn ptn  lst_1 lst_2 lst_3 lst_4 nth_n $dist);;;;;局部变量自己填吧,习惯还没改过来
   
5.          
   
6.   (vl-load-com)
   
7.   (setvar "cmdecho" 0)   
   
8.     (if (SETQ SS (ssget  '((0 . "*TEXT" ))))
   
9.      (progn
   
10.      (SETQ nn 1)
    
11.   (SETQ SS0(ENTGET (SSNAME SS 0)))
    
12.   (setq height (CDR(ASSOC 40 SS0)))
    
13.   (SETQ PT0(list (CDR(ASSOC 10 SS0))(CDR(ASSOC -1 SS0))))
    
14.   (SETQ LST_0 (LIST PT0))
    
15.   (REPEAT (-(SSLENGTH SS) 1)
    
16.    (SETQ SSN(ENTGET (SSNAME SS nn)))
    
17.    (SETQ PTN (list (CDR(ASSOC 10 SSN))(CDR(ASSOC -1 SSN))))
    
18.    (SETQ LST_0(REVERSE (APPEND(LIST PTN)(REVERSE LST_0))))
    
19.    (SETQ nn (1+ nn))
    
20.   )
    
21.    (princ"\n 共选中")(princ (sslength ss))(princ "个文本")
    
22.    
    
23. ;;;;;;;;;;;;;;;;;;;;;;;;;根据距离不同进行分组;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
24. 
    
25.   (setq txt_lst(vl-sort LST_0(function(lambda (x1 x2)
    
26.     (>(cadar x1) (cadar x2))))))
    
27.     (setq txt_lst1 (cdr txt_lst))
    
28.     (setq txt_lst2 (reverse(cdr(reverse txt_lst))))
    
29.   
    
30.     (setq lst_dist(vl-sort (mapcar (function (lambda(x y)(-(cadar x )(cadar y )))) txt_lst2 txt_lst1)'>))
    
31.     (setq lst_$dist1 (cdr lst_dist))
    
32.     (repeat (length lst_dist)
    
33.     (setq lst_dist11(vl-remove nil (mapcar (function (lambda(x y)(if (/= x  y )  x ))) lst_dist lst_$dist1)))
    
34.     )
    
35.      (setq lst_dist (append lst_dist11 (list (last lst_dist))))
    
36.     (princ  "\n 文字间距列表清单如下")
    
37.     (princ  lst_dist )
    
38.    (initget 128 "Y N")
    
39.    (setq key (getkword "\n  是否需要重新确定各组间距?<Y> \n 或以程序默认的列表第一个间距值?(N)<右键默认>"))
    
40. 
    
41.     (if (not key)(setq key "N"))
    
42. (if (= key "N")(progn
    
43. (cond ((= (length lst_dist)1)
    
44.         (setq $dist (+(car lst_dist)1e-3)))
    
45.        ((= (length lst_dist)2)
    
46.         (setq $dist (car lst_dist)))
    
47.        ((> (length lst_dist)2)
    
48.    (setq $dist (cadr (reverse lst_dist))))
    
49.      )

;;;;;;;;;;;;;找出各组对应位置最大值 BY YJR111 2011-10-30;;;;;;;;;;;;;;;;;;;;;;;<br /> <br /> (DEFUN c:findmaxnum(/ nn mm ss n ss0 pt0 lst ssn ptn  lst_1 lst_2 lst_3 lst_4 nth_n $dist);;;;;局部变量自己填吧,习惯还没改过来<br />           <br />   (vl-load-com)<br />   (setvar "cmdecho" 0)    <br />     (if (SETQ SS (ssget  '((0 . "*TEXT" ))))<br />      (progn<br />      (SETQ nn 1)<br />   (SETQ SS0(ENTGET (SSNAME SS 0)))<br />   (setq height (CDR(ASSOC 40 SS0)))<br />   (SETQ PT0(list (CDR(ASSOC 10 SS0))(CDR(ASSOC -1 SS0))))<br />   (SETQ LST_0 (LIST PT0))<br />   (REPEAT (-(SSLENGTH SS) 1)<br />    (SETQ SSN(ENTGET (SSNAME SS nn)))<br />    (SETQ PTN (list (CDR(ASSOC 10 SSN))(CDR(ASSOC -1 SSN))))<br />    (SETQ LST_0(REVERSE (APPEND(LIST PTN)(REVERSE LST_0))))<br />    (SETQ nn (1+ nn))<br />   )<br />    (princ"\n 共选中")(princ (sslength ss))(princ "个文本")<br />    <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;根据距离不同进行分组;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> <br />   (setq txt_lst(vl-sort LST_0(function(lambda (x1 x2)<br />     (>(cadar x1) (cadar x2))))))<br />     (setq txt_lst1 (cdr txt_lst))<br />     (setq txt_lst2 (reverse(cdr(reverse txt_lst))))<br />   <br />     (setq lst_dist(vl-sort (mapcar (function (lambda(x y)(-(cadar x )(cadar y )))) txt_lst2 txt_lst1)'>))<br />     (setq lst_$dist1 (cdr lst_dist))<br />     (repeat (length lst_dist)<br />     (setq lst_dist11(vl-remove nil (mapcar (function (lambda(x y)(if (/= x  y )  x ))) lst_dist lst_$dist1)))<br />     )<br />      (setq lst_dist (append lst_dist11 (list (last lst_dist))))<br />     (princ  "\n 文字间距列表清单如下")<br />     (princ  lst_dist )<br />    (initget 128 "Y N")<br />    (setq key (getkword "\n  是否需要重新确定各组间距?<Y> \n 或以程序默认的列表第一个间距值?(N)<右键默认>"))<br /> <br />     (if (not key)(setq key "N"))<br /> (if (= key "N")(progn<br /> (cond ((= (length lst_dist)1)<br />         (setq $dist (+(car lst_dist)1e-3)))<br />        ((= (length lst_dist)2)<br />         (setq $dist (car lst_dist)))<br />        ((> (length lst_dist)2)<br />    (setq $dist (cadr (reverse lst_dist))))<br />      )

飞诗(fsxm)

俺26楼又更新了一下速度加快N倍罗，
2000个文字基本上能秒杀了！可以测试下！
老规矩50楼发源码！