批改图框页码，选择集排序疑问

飒路紫

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=180224&mobile=2

xvjiex

这应该是你要的。

2. (princ "\n★功能：批量改图框页码，请输入 ym 命令。原著：by 李晓卓；修改：xvjiex\n")
   
3. (if (null vlax-dump-object) (vl-load-com) )
   
4. (defun xz-att (ent tag string / liST0 liST1 num blkref)
   
5.   (vl-load-com)
   
6.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
   
7.     (if (vla-Get-HasAttributes blkref)
   
8.       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))
   
9.        (setq liST1 (mapcar 'vla-Get-TagString  liST0))
   
10.              (setq num (vl-position tag list1))
    
11.              (vla-put-TextString (nth num liST0) string)
    
12.   )
    
13.     ); endif
    
14.   ); endif
    
15.   (prin1)
    
16. ); enddefun
    
17. ;(setq  ent  (car (entsel)))   例子
    
18. ;(xz-att ent "页码" 30)   例子
    
19. 
    
20. ;***********
    
21. (defun c:YM (/ EP1 EG1 EG2 blktag EP1st blkname str GETK prefix sttr
    
22.        index0 index sslist XZ_sortlist len0 len sslist_ptl )
    
23.   (vl-load-com)
    
24.   (if (progn
    
25.      (setq EP1 (entsel "\n点取属性块中，页码的位置:"))
    
26.         (setq EG1 (cdr (assoc 0 (entget (car EP1)))))
    
27.            (if (/= EG1 "INSERT")
    
28.        (progn(princ "\n必须选择属性块.")(exit)(princ))
    
29.              (progn (setq EG2 (car (nentselp (cadr EP1))))
    
30.                    (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
    
31.                  (setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
    
32.        )
    
33.              (setq EP1st (entget (car EP1)))
    
34.              (setq blkname (assoc 2 EP1st))
    
35.          )
    
36.          )
    
37.          )
    
38.         (princ (strcat "  块名为:" (cdr blkname) "   标记为:" blktag "\n"))
    
39.          (progn(princ "  必须选择属性块!")(exit))
    
40.          )        
    
41.   
    
42.   ;开始选择页码块并修改
    
43.   (setq prefix (getstring "请输入前缀:"))
    
44.   (if (=  str0  nil) (setq str0 1)) (initget 6)
    
45.   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0 2 0) ">:")))
    
46.   (if (= str  nil)(setq str  str0))
    
47.   
    
48.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
    
49.   (princ ">>选择批量修改页码的对象...")
    
50.   (setq ss (ssget  (cons blkname slist)))
    
51.   (setq index0 0 index (sslength ss) sslist '())   
    
52.   (repeat index
    
53.     (setq sslist (cons (ssname ss index0) sslist))
    
54.     (setq index0 (1+ index0))
    
55.   )
    
56. 
    
57. 
    
58.   ;开始构建图元点位表
    
59.   (setq index0 0  sslist_ptl '() tmp_pt '())   
    
60.   (repeat index
    
61.     ;(setq e_obj (vlax-ename->vla-object (entget (nth index0 sslist))))
    
62.     (setq e_obj (vlax-ename->vla-object  (nth index0 sslist)))
    
63.     (vla-getboundingbox e_obj 'minpt 'maxpt)
    
64.     (setq tmp_pt (cons (nth index0 sslist) (cons (vlax-safearray->list  minpt) tmp_pt)))
    
65.     (setq sslist_ptl (cons tmp_pt sslist_ptl))
    
66.     (setq tmp_pt '())
    
67.     (setq index0 (1+ index0))
    
68.   )
    
69. 
    
70. 
    
71. 
    
72. 
    
73.   ;开始排序
    
74.   (cond      
    
75.   ;从左到右从上到下
    
76.   ((or (= GETK "H")(= GETK nil))
    
77.     (setq XZ_sortlist (vl-sort
    
78.       (vl-sort sslist_ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
    
79.       '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
    
80.   )
    
81.   ;从上到下从左到右
    
82.   ((= GETK "V")
    
83.     (setq XZ_sortlist (vl-sort
    
84.       (vl-sort sslist_ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
    
85.       '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
    
86.    )
    
87.    ;选择顺序
    
88.   ((= GETK "S")
    
89.     (setq XZ_sortlist  sslist_ptl))
    
90.    );cond
    
91.   ;开始修改页码
    
92.     (setq len0 0 len (length XZ_sortlist))
    
93.     (repeat len
    
94.      (if (setq ent0 (car (nth len0 XZ_sortlist)))
    
95.    (progn
    
96.      (cond
    
97.        ((/= prefix "")
    
98.      (if (=(strlen (rtos str))1)
    
99.        (setq sttr (strcat prefix "0" (rtos str 2 0) "页"))
    
100.        (setq sttr (strcat prefix (rtos str 2 0) "页"))
     
101.      ))
     
102.        ((= prefix "")(setq sttr  (strcat (rtos str 2 0) "页")))
     
103.      );cond
     
104.      (xz-att ent0 blktag sttr)
     
105.      (princ (strcat " >>已修改至页:" (rtos str 2 0) "、"))
     
106.      (setq len0 (1+ len0) str (1+ str))
     
107.      (setq str0  str)      
     
108.    )
     
109.       )
     
110.   );repeat
     
111.   (prin1)
     
112. )
     

(princ "\n★功能：批量改图框页码，请输入 ym 命令。原著：by 李晓卓；修改：xvjiex\n")<br /> (if (null vlax-dump-object) (vl-load-com) )<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")<br />     (if (vla-Get-HasAttributes blkref)<br />       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))<br />        (setq liST1 (mapcar 'vla-Get-TagString  liST0))<br />              (setq num (vl-position tag list1))<br />              (vla-put-TextString (nth num liST0) string)<br />   )<br />     ); endif<br />   ); endif<br />   (prin1)<br /> ); enddefun<br /> ;(setq  ent  (car (entsel)))   例子<br /> ;(xz-att ent "页码" 30)   例子<br /> <br /> ;***********<br /> (defun c:YM (/ EP1 EG1 EG2 blktag EP1st blkname str GETK prefix sttr<br />        index0 index sslist XZ_sortlist len0 len sslist_ptl )<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(princ "\n必须选择属性块.")(exit)(princ))<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 />   ;开始选择页码块并修改<br />   (setq prefix (getstring "请输入前缀:"))<br />   (if (=  str0  nil) (setq str0 1)) (initget 6)<br />   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0 2 0) ">:")))<br />   (if (= str  nil)(setq str  str0))<br />   <br />   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))<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 /> <br />   ;开始构建图元点位表<br />   (setq index0 0  sslist_ptl '() tmp_pt '())   <br />   (repeat index<br />     ;(setq e_obj (vlax-ename->vla-object (entget (nth index0 sslist))))<br />     (setq e_obj (vlax-ename->vla-object  (nth index0 sslist)))<br />     (vla-getboundingbox e_obj 'minpt 'maxpt)<br />     (setq tmp_pt (cons (nth index0 sslist) (cons (vlax-safearray->list  minpt) tmp_pt)))<br />     (setq sslist_ptl (cons tmp_pt sslist_ptl))<br />     (setq tmp_pt '())<br />     (setq index0 (1+ index0))<br />   )<br /> <br /> <br /> <br /> <br />   ;开始排序<br />   (cond      <br />   ;从左到右从上到下<br />   ((or (= GETK "H")(= GETK nil))<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)))<br />    (progn<br />      (cond<br />        ((/= prefix "")<br />      (if (=(strlen (rtos str))1)<br />        (setq sttr (strcat prefix "0" (rtos str 2 0) "页"))<br />        (setq sttr (strcat prefix (rtos str 2 0) "页"))<br />      ))<br />        ((= prefix "")(setq sttr  (strcat (rtos str 2 0) "页")))<br />      );cond <br />      (xz-att ent0 blktag sttr)<br />      (princ (strcat " >>已修改至页:" (rtos str 2 0) "、"))<br />      (setq len0 (1+ len0) str (1+ str))<br />      (setq str0  str)      <br />    )<br />       )<br />   );repeat<br />   (prin1) <br /> )<br />

Klein

xvjiex 发表于 2020-1-15 09:25
这应该是你要的。

非常感谢！自己写了个图框程序，正愁如何自动化命名，刚好找到了这个帖子！