源代码:批量改页码(加前缀)及提取属性块

773786668

好东西，先顶了！

ㄘ丶转裑ㄧ灬

       李工，因有旋转（即竖向）的图框，且块比例都不相同，但图框下端都在一水平线上，
                 所以排序时是否可以修改为以图框的左下角点进行排序？
       参考了好多的排序函数，但都没顺利的修改出来，请有时间的时候帮忙修改下，谢谢！！

我是木木可

感谢分享。受益匪浅

yxl88168

感谢楼主 的确改页码 自动递增就更好

yxl88168

此程序有时会出现尾数出现（.0000）用的CAD是2008的，有时又不会出现，你能帮忙优化一下吗

1028882406@qq.c

谢谢楼主，支持下

xcmdos

顶你！放源码就是好兄弟。谢谢分享

shopping200

yxl88168 发表于 2017-8-25 13:43
此程序有时会出现尾数出现（.0000）用的CAD是2008的，有时又不会出现，你能帮忙优化一下吗

1. ;更改属性块标记tag所对应的值string
   
2. (defun xz-att (ent tag string / liST0 liST1 num blkref)
   
3.   (vl-load-com)
   
4.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
   
5.     (if (vla-Get-HasAttributes blkref)
   
6.       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))
   
7.              (setq liST1 (mapcar 'vla-Get-TagString  liST0))
   
8.              (setq num (vl-position tag list1))
   
9.              (vla-put-TextString (nth num liST0) string)
   
10.         )
    
11.     ); endif
    
12.   ); endif
    
13.   (prin1)
    
14. ); enddefun
    
15. ;(setq  ent  (car (entsel)))   例子
    
16. ;(xz-att ent "页码" 30)   例子
    
17. 
    
18. 
    
19. ;******************************************************************************
    
20. ;******************************************************************************
    
21. ;******************************************************************************
    
22. (defun c:yema (/ EP1 EG1 EG2 blktag EP1st blkname str GETK prefix sttr
    
23.              index0 index sslist XZ_sortlist len0 len sslist-ptl index0)
    
24.   (vl-load-com)
    
25.   (if (progn
    
26.            (setq EP1 (entsel"点取属性块中页码的位置:\n"))
    
27.            (setq EG1 (cdr (assoc 0 (entget (car EP1)))))
    
28.            (if (= EG1 "INSERT")
    
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.   (setq prefix (getstring "请输入前缀:"))
    
43.   (if (=  str0  nil) (setq str0 1)) (initget 6)
    
44.   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0 2 0) ">:")))
    
45.   (if (= str  nil)(setq str  str0))
    
46.   
    
47.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
    
48.   (princ ">>选择批量修改页码的对象...")
    
49.   (setq ss (ssget  (cons blkname slist)))
    
50.   (setq index0 0 index (sslength ss) sslist '())         
    
51.   (repeat index
    
52.     (setq sslist (cons (ssname ss index0) sslist))
    
53.     (setq index0 (1+ index0))
    
54.   )
    
55.   ;开始构建图元点位表
    
56.   (setq index0 0  sslist-ptl '() tmp-pt '())         
    
57.   (repeat index
    
58.     (setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
    
59.     (setq sslist-ptl (cons tmp-pt sslist-ptl))
    
60.     (setq tmp-pt '())
    
61.     (setq index0 (1+ index0))
    
62.   )
    
63.   ;开始排序
    
64.   (cond      
    
65.   ;从左到右从上到下
    
66.   ((or (= GETK "H")(= GETK nil))
    
67.     (setq XZ_sortlist (vl-sort
    
68.                         (vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
    
69.                         '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
    
70.   )
    
71.   ;从上到下从左到右
    
72.   ((= GETK "V")
    
73.     (setq XZ_sortlist (vl-sort
    
74.                         (vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
    
75.                         '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
    
76.    )
    
77.    ;选择顺序
    
78.   ((= GETK "S")
    
79.     (setq XZ_sortlist  sslist-ptl))
    
80.    );cond
    
81.   ;开始修改页码
    
82.     (setq len0 0 len (length XZ_sortlist))
    
83.     (repeat len
    
84.      (if (setq ent0 (car (nth len0 XZ_sortlist)))
    
85.          (progn
    
86.            (cond
    
87.              ((/= prefix "")
    
88.            (if (=(strlen (rtos str))1)
    
89.              (setq sttr (strcat prefix "0" (rtos str 2 0)))
    
90.              (setq sttr (strcat prefix (rtos str 2 0)))
    
91.            ))
    
92.              ((= prefix "")(setq sttr  (rtos str 2 0)))
    
93.            );cond
    
94.            (xz-att ent0 blktag sttr)
    
95.            (princ (strcat "-->正在修改页码 <" (rtos str 2 0) ">  "))
    
96.            (setq len0 (1+ len0) str (1+ str))
    
97.            (setq str0  str)                 
    
98.          )
    
99.       )
    
100.   );repeat
     
101.   (prin1)
     
102. )
     
103. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     
104. (defun c:pginf ()
     
105. (alert "                                           欢迎使用本程序\n
     
106.          1.本程序为做越南万豪酒店施工图时所写.\n
     
107.          2.本程序使用VisualLISP语言.\n
     
108.          3.基于程序思想可以实现增加前缀(已增加)及按页码打印,有空且心情好时再写.\n
     
109.          4.本程序排序方法为属性块的插入点.\n
     
110.          5.本程序通过ActiveX提取了属性块的标记而后修改相应的值.\n
     
111.          6.程序已加密恕不提供源码.\n
     
112.          7.如有疑问请自行保留.\n
     
113.                                                                         ---by 李晓卓 2010.11.17
     
114.                                                                         ---RTX:60315
     
115.         ")(prin1)
     
116.   )
     
117. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
     
118. (princ "\n************************************************")
     
119. (princ "\n**    批量改页码 pg.lsp已加载                 **")
     
120. (princ "\n**      >>批量改页码,以pg启动命令             **")
     
121. (princ "\n**      >>查看程序信息,以pginf启动命令        **")
     
122. (princ "\n**                          ----by 李晓卓     **")
     
123. (princ "\n**                              2010.11.17    **")
     
124. (princ "\n************************************************")
     
125. (princ)

;更改属性块标记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")<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 /> ;******************************************************************************<br /> ;******************************************************************************<br /> ;******************************************************************************<br /> (defun c:yema (/ EP1 EG1 EG2 blktag EP1st 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 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 />   (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 />   ;从左到右从上到下<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  (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 /> ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++<br /> (defun c:pginf ()<br /> (alert "                                           欢迎使用本程序\n<br />          1.本程序为做越南万豪酒店施工图时所写.\n<br />          2.本程序使用VisualLISP语言.\n<br />          3.基于程序思想可以实现增加前缀(已增加)及按页码打印,有空且心情好时再写.\n<br />          4.本程序排序方法为属性块的插入点.\n<br />          5.本程序通过ActiveX提取了属性块的标记而后修改相应的值.\n<br />          6.程序已加密恕不提供源码.\n<br />          7.如有疑问请自行保留.\n<br />                                                                         ---by 李晓卓 2010.11.17<br />                                                                         ---RTX:60315<br />         ")(prin1)<br />   )<br /> ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++<br /> (princ "\n************************************************")<br /> (princ "\n**    批量改页码 pg.lsp已加载                 **")<br /> (princ "\n**      >>批量改页码,以pg启动命令             **")<br /> (princ "\n**      >>查看程序信息,以pginf启动命令        **")<br /> (princ "\n**                          ----by 李晓卓     **")<br /> (princ "\n**                              2010.11.17    **")<br /> (princ "\n************************************************")<br /> (princ)

jwoo8oo

太好了，找到相应的东西

yxl88168

shopping200 发表于 2017-12-27 09:18

谢谢您，我下来试一下，好久没上明经了，今天才看到