网上下载的页码任意排序源码，请高手完善

wanhongron

网上下载的页码任意排序源码，可实现属性块序号自动从小到大排列，但我想增加一个增值功能，即能是序号同加或同减一个数，如3、5、8同加1后得4、6、9，涂鸦了一下，未成功，请大侠修改一下。

bai2000

怎么我的页码变为：DT-1.0000的样式了，我的原意页码应为： DT-01、DT-02。。。。。。。。。希望大神改改

jkop

xiaxiang 发表于 2012-1-30 08:21
原作者是本论坛的LLXXZZ，请先注明。
代码我改了一下，传上来。
1. 第一个函数xz-at有问题，修改了一下

感谢分享源码，经测试使用没问题，但页码生成后会产生小数点4位数的0，如1.0000    2.0000   3.0000...
如若可以，还请帮忙修改，敝人感激～

夜冥音

xiaxiang 发表于 2012-1-30 08:21
原作者是本论坛的LLXXZZ，请先注明。
代码我改了一下，传上来。
1. 第一个函数xz-at有问题，修改了一下

能增加对动态块的选择吗？这个选不了动态块

xiaxiang

原作者是本论坛的LLXXZZ，请先注明。
代码我改了一下，传上来。

2. 
   
3. ;;;页码任意修改
   
4. ;1读取属性块标记tag所对应的值string
   
5. (defun xz-at (ent tag / liST0 liSTt1 blkref a)
   
6.   (vl-load-com)
   
7.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
   
8.     (if (vla-Get-HasAttributes blkref)
   
9.       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))
   
10.       (setq liSTt1 (mapcar 'vla-Get-TagString  liST0))   
    
11.       )
    
12.     ); endif
    
13.   ); endif
    
14.       (setq num (vl-position tag liSTt1))  ;;返回tag在list1中的排位位置
    
15.       (setq a (vla-get-TextString(nth num liST0))) ;;返回list0中第num个元素,取得该图元的textstring字符串
    
16.       a
    
17. ); enddefun
    
18. ;2更改属性块标记tag所对应的值string
    
19. (defun xz-att (ent tag string / liST0 liST1 num blkref)
    
20.   (vl-load-com) ;;加载扩展功能
    
21.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference") ;;将ent转为vla对象blref,取得名称,判断是否同后面一致
    
22.     (if (vla-Get-HasAttributes blkref) ;;blkref块是否有属性
    
23.       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref)))) ;;取得块属性,返回值,属性值列表list0
    
24.       (setq liST1 (mapcar 'vla-Get-TagString  liST0)) ;;取得list0每个标签字符串,赋给列表list1
    
25.              (setq num (vl-position tag list1))  ;;返回tag在list1中的排位位置
    
26.              (vla-put-TextString (nth num liST0) string) ;;返回list0中第num个元素,把string字符串赋给设定该图元
    
27. )
    
28.     ); endif
    
29.   ); endif
    
30.   (prin1)
    
31. ); enddefun
    
32. ;3主程序
    
33. (defun c:ympx (/ EP1 EG1 EG2  EP1st blktag blkname str GETK prefix sttr
    
34.       index0 index sslist XZ_sortlist len0 len sslist_ptl index0)
    
35.   (vl-load-com)
    
36.   (if (progn
    
37.     (setq EP1 (entsel"点取属性块中页码的位置:\n"))
    
38.            (setq EG1 (cdr (assoc 0 (entget (car EP1)))))
    
39.            (if (= EG1 "INSERT")
    
40.                (progn (setq EG2 (car (nentselp (cadr EP1))))
    
41.                    (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
    
42.                 (setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
    
43.      )
    
44.             (setq EP1st (entget (car EP1)))
    
45.             (setq blkname (assoc 2 EP1st))   
    
46.         )
    
47.    )
    
48.         )
    
49.   (princ (strcat"  块名为-->" (cdr blkname) "   标记为-->" blktag "\n"))
    
50.          (progn(princ "  必须选择属性块!")(exit))
    
51.   )
    
52.   ;开始选择页码块并修改
    
53.   (setq prefix (getstring "请输入前缀:"))
    
54.   (if (=  str0  nil) (setq str0 1)) (initget 6)
    
55.   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0) ">:")))
    
56.   (if (= str  nil)(setq str  str0))
    
57.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [数值增加(回车)/横向优先(H)/竖向优先(V)/选择优先(S)]: <回车> "))
    
58.   (princ ">>选择批量修改页码的对象...")
    
59.   (setq ss (ssget  (cons blkname slist)))
    
60.   (setq index0 0 index (sslength ss) sslist '())  
    
61.   (repeat index
    
62.     (setq sslist (cons (ssname ss index0) sslist))
    
63.     (setq index0 (1+ index0))
    
64.   )
    
65.   ;开始构建图元点位表
    
66.   (setq index0 0  sslist_ptl '() tmp-pt '())  
    
67.   (repeat index
    
68.     (setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
    
69.     (setq sslist_ptl (cons tmp-pt sslist_ptl))
    
70.     (setq tmp-pt '())
    
71.     (setq index0 (1+ index0))
    
72.   )
    
73.   ;开始排序
    
74.   (cond      
    
75.   ((= GETK nil)
    
76.   ;开始增值
    
77.   (if (=  str1  nil) (setq str2 1))
    
78.   (setq str1 (getint (strcat "请输入增值<" (rtos str2) ">:")))
    
79.   (if (= str1  nil)(setq str1  str2))
    
80.     (setq len0 0 len (length sslist_ptl))
    
81.     (repeat len
    
82.                  (setq ent0 (car (nth len0 sslist_ptl)))  ;;返回第len0个图元的名称
    
83.                  (setq sttr (+ (atoi(xz-at ent0 blktag)) str1))
    
84.     (xz-att ent0 blktag sttr)
    
85.     (princ (strcat "-->增值 <" (rtos str1) ">  "))
    
86.     (setq len0 (1+ len0))  
    
87.       );repeat
    
88.   )
    
89.   ;从左到右从上到下
    
90.   ((= GETK "H")
    
91.     (setq XZ_sortlist (vl-sort
    
92.    (vl-sort sslist_ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
    
93.    '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
    
94.   )
    
95.   ;从上到下从左到右
    
96.   ((= GETK "V")
    
97.     (setq XZ_sortlist (vl-sort
    
98.    (vl-sort sslist_ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
    
99.    '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
    
100.    )
     
101.    ;选择顺序
     
102.   ((= GETK "S")
     
103.     (setq XZ_sortlist  sslist_ptl))
     
104.    );cond
     
105.   ;开始修改页码
     
106.     (setq len0 0 len (length XZ_sortlist))
     
107.     (repeat len
     
108.      (if (setq ent0 (car (nth len0 XZ_sortlist)))  ;;返回第len0个图元的名称
     
109.   (progn
     
110.     (cond
     
111.       ((/= prefix "")
     
112.     (if (=(strlen (rtos str))1)
     
113.       (setq sttr (strcat prefix "0" (rtos str)))
     
114.       (setq sttr (strcat prefix (rtos str)))
     
115.     ))
     
116.       ((= prefix "")(setq sttr  (rtos str)))
     
117.     );cond
     
118.     (xz-att ent0 blktag sttr)
     
119.     (princ (strcat "-->修码 <" (rtos str) ">  "))
     
120.     (setq len0 (1+ len0) str (1+ str))
     
121.     (setq str0  str)         
     
122.   )
     
123.       )
     
124.   );repeat
     
125.   (prin1)
     
126. )
     
127. (princ "\n************************************************")
     
128. (princ "\n**    任意改页码 ympx.lsp已加载                 **")
     
129. (princ "\n**      >>任意改页码,以ympx启动命令             **")
     
130. (princ "\n**  ----by 李晓卓 modified by xiaxiang    **")
     
131. (princ "\n**                              2012.01.30    **")
     
132. (princ "\n************************************************")
     
133. (princ)

<br /> ;;;页码任意修改<br /> ;1读取属性块标记tag所对应的值string<br /> (defun xz-at (ent tag / liST0 liSTt1 blkref a)<br />   (vl-load-com)<br />   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")<br />     (if (vla-Get-HasAttributes blkref)<br />       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))<br />       (setq liSTt1 (mapcar 'vla-Get-TagString  liST0))    <br />       )<br />     ); endif<br />   ); endif<br />       (setq num (vl-position tag liSTt1))  ;;返回tag在list1中的排位位置<br />       (setq a (vla-get-TextString(nth num liST0))) ;;返回list0中第num个元素,取得该图元的textstring字符串<br />       a<br /> ); enddefun<br /> ;2更改属性块标记tag所对应的值string<br /> (defun xz-att (ent tag string / liST0 liST1 num blkref)<br />   (vl-load-com) ;;加载扩展功能<br />   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference") ;;将ent转为vla对象blref,取得名称,判断是否同后面一致<br />     (if (vla-Get-HasAttributes blkref) ;;blkref块是否有属性<br />       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref)))) ;;取得块属性,返回值,属性值列表list0<br />       (setq liST1 (mapcar 'vla-Get-TagString  liST0)) ;;取得list0每个标签字符串,赋给列表list1<br />              (setq num (vl-position tag list1))  ;;返回tag在list1中的排位位置<br />              (vla-put-TextString (nth num liST0) string) ;;返回list0中第num个元素,把string字符串赋给设定该图元<br /> )<br />     ); endif<br />   ); endif<br />   (prin1)<br /> ); enddefun<br /> ;3主程序<br /> (defun c:ympx (/ EP1 EG1 EG2  EP1st blktag blkname str GETK prefix sttr<br />       index0 index sslist XZ_sortlist len0 len sslist_ptl index0)<br />   (vl-load-com)<br />   (if (progn<br />     (setq EP1 (entsel"点取属性块中页码的位置:\n"))<br />            (setq EG1 (cdr (assoc 0 (entget (car EP1)))))<br />            (if (= EG1 "INSERT")<br />                (progn (setq EG2 (car (nentselp (cadr EP1))))<br />                    (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")<br />                 (setq blktag (cdr (assoc 2 (entget EG2)))) ;标记 <br />      )<br />             (setq EP1st (entget (car EP1)))<br />             (setq blkname (assoc 2 EP1st))   <br />         )<br />    )<br />         )<br />   (princ (strcat"  块名为-->" (cdr blkname) "   标记为-->" blktag "\n"))<br />          (progn(princ "  必须选择属性块!")(exit))<br />   )<br />   ;开始选择页码块并修改<br />   (setq prefix (getstring "请输入前缀:"))<br />   (if (=  str0  nil) (setq str0 1)) (initget 6)<br />   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0) ">:"))) <br />   (if (= str  nil)(setq str  str0))<br />   (initget "H V S ")(setq GETK (getkword "排序方式:\n [数值增加(回车)/横向优先(H)/竖向优先(V)/选择优先(S)]: <回车> "))<br />   (princ ">>选择批量修改页码的对象...")<br />   (setq ss (ssget  (cons blkname slist)))<br />   (setq index0 0 index (sslength ss) sslist '())  <br />   (repeat index<br />     (setq sslist (cons (ssname ss index0) sslist))<br />     (setq index0 (1+ index0))<br />   )<br />   ;开始构建图元点位表<br />   (setq index0 0  sslist_ptl '() tmp-pt '())  <br />   (repeat index<br />     (setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))<br />     (setq sslist_ptl (cons tmp-pt sslist_ptl))<br />     (setq tmp-pt '())<br />     (setq index0 (1+ index0))<br />   )<br />   ;开始排序<br />   (cond      <br />   ((= GETK nil)<br />   ;开始增值<br />   (if (=  str1  nil) (setq str2 1)) <br />   (setq str1 (getint (strcat "请输入增值<" (rtos str2) ">:")))<br />   (if (= str1  nil)(setq str1  str2))<br />     (setq len0 0 len (length sslist_ptl))<br />     (repeat len<br />                  (setq ent0 (car (nth len0 sslist_ptl)))  ;;返回第len0个图元的名称<br />                  (setq sttr (+ (atoi(xz-at ent0 blktag)) str1)) <br />     (xz-att ent0 blktag sttr)<br />     (princ (strcat "-->增值 <" (rtos str1) ">  "))<br />     (setq len0 (1+ len0))  <br />       );repeat<br />   )<br />   ;从左到右从上到下<br />   ((= GETK "H")<br />     (setq XZ_sortlist (vl-sort<br />    (vl-sort sslist_ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))<br />    '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   <br />   )<br />   ;从上到下从左到右<br />   ((= GETK "V")<br />     (setq XZ_sortlist (vl-sort<br />    (vl-sort sslist_ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))<br />    '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))    <br />    )<br />    ;选择顺序<br />   ((= GETK "S")<br />     (setq XZ_sortlist  sslist_ptl))<br />    );cond <br />   ;开始修改页码<br />     (setq len0 0 len (length XZ_sortlist))<br />     (repeat len<br />      (if (setq ent0 (car (nth len0 XZ_sortlist)))  ;;返回第len0个图元的名称<br />   (progn<br />     (cond<br />       ((/= prefix "")<br />     (if (=(strlen (rtos str))1)<br />       (setq sttr (strcat prefix "0" (rtos str)))<br />       (setq sttr (strcat prefix (rtos str)))<br />     ))<br />       ((= prefix "")(setq sttr  (rtos str)))<br />     );cond <br />     (xz-att ent0 blktag sttr)<br />     (princ (strcat "-->修码 <" (rtos str) ">  "))<br />     (setq len0 (1+ len0) str (1+ str))<br />     (setq str0  str)          <br />   )<br />       )<br />   );repeat<br />   (prin1) <br /> )<br /> (princ "\n************************************************")<br /> (princ "\n**    任意改页码 ympx.lsp已加载                 **")<br /> (princ "\n**      >>任意改页码,以ympx启动命令             **")<br /> (princ "\n**  ----by 李晓卓 modified by xiaxiang    **")<br /> (princ "\n**                              2012.01.30    **")<br /> (princ "\n************************************************")<br /> (princ)

1. 第一个函数xz-at有问题，修改了一下
2. 起始值和增值不应放在一起处理
3. 变量名中不应使用“-”，使用“_”要好一些
4. vla-Get-TagString和vla-Get-TextString的区别应理解一下

LLXXZZ

原创者 路过。。。
感谢使用。

429014673

LLXXZZ 发表于 2012-1-30 12:33 原创者 路过。。。 感谢使用。

希望老大小改一下：那个横向页码排序是从左到右，与y坐标的大小无关

669423907

哈哈，好铁需要多炼啊！只是我没火。

lichunlin

初学者，看不懂！悲催了！

wanhongron

正是我所要的效果，xiaxiang大侠[em80解释的非常详细，非常专业，对xiaxiang大侠和原创LLXXZZ表示衷心的感谢和祝福，祝愿新年龙马精神，龙腾虎跃。

longer1000

剑昕

撒花 撒花~

剑昕

这程序写的真不错