设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 源代码:批量改页码(加前缀)及提取属性块
12345678910... 11下一页
返回列表 发新帖
查看: 41909|回复: 109

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

    [复制链接]
LLXXZZ
发表于 2011-9-2 21:19:26 | 显示全部楼层 |阅读模式
本帖最后由 LLXXZZ 于 2011-9-4 14:58 编辑

在这个网页中
http://bbs.mjtd.com/thread-64566-1-1.html
有哥们确实向我要了源码,可能有些兄弟确实想看代码.现在给贴出来.
代码一般.没什么大不了的.但也着实让不少同仁受益.
页码的排序的功能写的不好,有优化的空间,懒得改了.哥们儿根据自己的需要自己改.


  2. ;提取属性块标记TagString或对应的值TextString
  3. ;ent:图元名,opt:为T程序返回TextString的表,为nil返回标记TagString的表
  4. (defun xz-att-g (ent opt / liST0 liSTt liSTg blkref a)
  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 liSTt (mapcar 'vla-Get-TagString  liST0))
  10.        (setq liSTg (mapcar 'vla-get-TextString  liST0))
  11.                      
  12.   )
  13.     ); endif
  14.   ); endif
  15.   (if opt (setq a liSTg) (setq a liSTt))
  16.   a
  17. ); enddefun
  18. ;(setq  ent  (car (entsel)))   例子
  19. ;(xz-att-g ent t)   (xz-att-g ent nil)例子


  22.    
  23. ;******************************************************************************
  24. ;******************************************************************************
  25. ;******************************************************************************
  26. (defun c:gat (/ EP1 blkname liSTt GETK ss index0 sslist tmp-pt sslist-ptl XZ_sortlist strlist
  27.         strlenlist0 nthx nthn strlenlist myentmk_line myentmk_text OSM BPM pt m)
  28.   (vl-load-com)
  29.   
  30.   (while (not (setq EP1 (entsel"点取带属性的块:\n"))))
  31.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object (car EP1)))) "AcDbBlockReference")
  32.     (if (vla-Get-HasAttributes blkref)
  33.       (progn
  34.         (setq blkname (assoc 2 (entget (car EP1))))
  35.         (setq liSTt (xz-att-g (car EP1) nil))
  36.         (princ (strcat"  属性块 块名为--> " (cdr blkname) "\n"))
  37.        )
  38.       )
  39.     (progn(princ "  必须选择属性块!")(exit))
  40.    )

  42.   ;开始选择页码块并修改

  44.   
  45.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
  46.   (princ ">>选择对象...")
  47.   (setq ss (ssget  (cons blkname slist)))
  48.   (setq index0 0 index (sslength ss) sslist '())   
  49.   (repeat index
  50.     (setq sslist (cons (ssname ss index0) sslist))
  51.     (setq index0 (1+ index0))
  52.   )
  53.   ;开始构建图元点位表
  54.   (setq index0 0  sslist-ptl '() tmp-pt '())   
  55.   (repeat index
  56.     (setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
  57.     (setq sslist-ptl (cons tmp-pt sslist-ptl))
  58.     (setq tmp-pt '())
  59.     (setq index0 (1+ index0))
  60.   )
  61.   ;开始排序
  62.   (cond      
  63.   ;从左到右从上到下
  64.   ((or (= GETK "H")(= GETK nil))
  65.     (setq XZ_sortlist (vl-sort
  66.       (vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
  67.       '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
  68.   )
  69.   ;从上到下从左到右
  70.   ((= GETK "V")
  71.     (setq XZ_sortlist (vl-sort
  72.       (vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
  73.       '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
  74.    )
  75.    ;选择顺序
  76.   ((= GETK "S")
  77.     (setq XZ_sortlist  sslist-ptl))
  78.    );cond
  79. ;计算表内每列字符最长长度存储在表strlenlist中
  80.   (setq strlist (mapcar  '(lambda (x) (xz-att-g (car x) t)) XZ_sortlist))
  81.   (setq strlenlist0 (mapcar  '(lambda (x) (mapcar 'strlen  x)) strlist))
  82.   (setq nthx 0 nthn (length (car strlenlist0)))
  83.   (setq strlenlist nil)
  84.   (while (< nthx nthn)
  85.     (setq nth1 (vl-sort strlenlist0 '(lambda (s1 s2) (>= (nth nthx s1) (nth nthx s2)))))
  86.     (setq strlenlist (cons (nth nthx (car nth1)) strlenlist))
  87.     (setq nthx (1+ nthx))
  88.   )
  89.   (setq strlenlist (reverse strlenlist))
  90.   ;____________________________
  91. ;生成图元子程序
  92.   (defun myentmk_line (pt1 pt2 );(起点(uCS) 终点(uCS) 图层 颜色)
  93.     (command "_.line" pt1 pt2 "")
  94.    )
  95.   ;(myentmk_line (getpoint)(getpoint))
  96.   (defun myentmk_text (cont pt1);(内容 起点)
  97.     (if (not (= "" cont)) (command "_.text" "J" "ml" pt1 3.0 0.0 cont ));对齐点为左中
  98.    )
  99.   ;(myentmk_text " " (getpoint))
  100.   ;____________________________  

  102.   ;提取初始状态
  103.   (setvar "CMDECHO" 0)
  104.   (setq OSM (Getvar "OSMODE" ))
  105.   (setq BPM (Getvar "blipmode"))
  106.   (setvar "OSMODE"  0)
  107.   (setvar "blipmode" 0)

  109.   ;判断文字样式
  110.   (command "_.undo" "group")
  111.   ;(if (tblsearch "style" "JHZX")
  112.     ;(setvar "TEXTSTYLE" "JHZX")
  113.     ;(command "-STYLE"  "JHZX"  "ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
  114.     (command "-STYLE"  "JHZX"  "ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
  115.   ;) ;设置字体样式JHZX为当前样式

  117.     ;_____________________________________________
  118.     ;绘制表格子程序
  119.   (defun drawtable (lis row pt / x0 yo len x1 n pta ptb)
  120.     (setq x0 (car pt) yo (cadr pt) len (length lis))
  121.     (setq charlen (apply '+ lis))
  122.     ;画横线
  123.     (setq  x1 (+(* 1.5 charlen) (car pt) (* 20 len)))
  124.     (setq  n 0)
  125.     (repeat (+ row 2)
  126.       (setq pta (list x0 (- yo (* n 4))) ptb (list x1 (- yo (* n 4))))
  127.       (myentmk_line pta ptb)
  128.       (setq  n (1+ n))
  129.     )
  130.     ;画竖线
  131.     (myentmk_line pt (polar pt (* 1.5 pi) (* (1+ row) 4)));第一根竖线
  132.     (setq  n 0 x1 x0)
  133.    (while (< n len)
  134.      (setq  x1 (+(* 1.5 (nth n lis)) 20  x1));第二根的x坐标n＝0
  135.      (setq pta (list x1 yo) ptb (polar pta (* 1.5 pi) (* (1+ row) 4)))
  136.      (myentmk_line pta ptb)
  137.      (setq  n (1+ n))
  138.      )
  139.    )
  140.   ;_____________________________________________

  142.   ;_____________________________________________
  143.     ;绘制文字子程序
  144.   (defun drawtext (strlist strlenlist pt / x0 x1 pta n )
  145.      ;pt第一个字的起点左中对齐，strlenlist字符长度表
  146.     (setq x0 (car pt) yo (cadr pt) len (length strlenlist))   
  147.     ;按横向写字
  148.     (myentmk_text (nth 0 strlist) pt);第一个文字
  149.     (setq  n 0 x1 x0)
  150.    (while (< n len)
  151.      (setq  x1 (+(* 1.5 (nth n strlenlist)) 20  x1));第二个文字的x坐标n＝0
  152.      (setq pta (list x1 yo) )
  153.      (myentmk_text (nth (1+ n) strlist) pta)
  154.      (setq  n (1+ n))
  155.      )
  156.    )
  157.   ;_____________________________________________

  159.   
  160.   ;开始绘制表格
  161.   (setvar "OSMODE"    OSM)
  162.   (while (not(setq pt (getpoint "指定表格的左上点:"))))
  163.   (if pt (setvar "OSMODE"  0))
  164.   (drawtable strlenlist index pt)
  165.    ;表格中写上文字
  166.   (drawtext liSTt strlenlist (list (+ 10 (car pt)) (- (cadr pt) 2)));第一排为属性标记
  167.   (setq m 0)
  168.   (repeat (length strlist)
  169.     (setq  pta (list (+ 10 (car pt)) (- (cadr pt) (* m 4) 6)))
  170.     (drawtext (nth m strlist) strlenlist pta)  
  171.     (setq m (1+ m))
  172.   )

  174.   (command "_.undo" "end")
  175.   ;还原初始状态
  176.   (setvar "OSMODE"    OSM)
  177.   (setvar "blipmode"  BPM)
  178.   (prin1)
  179. )


  182. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

  184. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  185. (defun c:gatinf ()
  186. (alert "                                  欢迎使用本程序\n
  187. 1.此程序以送别同仁肖俊，今日他离职了，此处留个记号以标记今天的这个特别的日子。\n
  188. 2.同时提醒自己： 一日不读则愚！\n
  189. 3.程序调用了cad的line与text命令，所以程序反应比较慢，主要是自己对enmake函数应用不精，
  190.    抓紧时间学习这个函数。使用此函数将提高程序运行速度！\n

  192.          
  193.                                                                   ---by 李晓卓 2011.3.14
  194.                                                                   ---RTX:60315
  195.   ")(prin1)
  196.   )
  197. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  198. (princ "\n************************************************")
  199. (princ "\n**    块属性提取 gat.lsp已加载                **")
  200. (princ "\n**      >>提取块属性,以gat启动命令            **")
  201. (princ "\n**      >>查看程序信息,以gatinf启动命令       **")
  202. (princ "\n**                           ----by 李晓卓    **")
  203. (princ "\n**                               2011.3.14    **")
  204. (princ "\n************************************************")
  205. (princ)
  2. ;更改属性块标记tag所对应的值string
  3. (defun xz-att (ent tag string / liST0 liST1 num blkref)
  4.   (vl-load-com)
  5.   (if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
  6.     (if (vla-Get-HasAttributes blkref)
  7.       (progn (setq liST0 (vlax-safearray->list  (vlax-variant-value (vla-GetAttributes blkref))))
  8.        (setq liST1 (mapcar 'vla-Get-TagString  liST0))
  9.              (setq num (vl-position tag list1))
  10.              (vla-put-TextString (nth num liST0) string)
  11.   )
  12.     ); endif
  13.   ); endif
  14.   (prin1)
  15. ); enddefun
  16. ;(setq  ent  (car (entsel)))   例子
  17. ;(xz-att ent "页码" 30)   例子

  19. ;*****************************************************************************
  20. ;排序方式
  21. (defun xz-x (s0)  (car (assoc 10 (entget s0))))   ;取出图元插入点的x坐标值
  22. (defun xz-y (s0)  (cadr (assoc 10 (entget s0))))  ;取出图元插入点的y坐标值
  23. (defun xz-z (s0)  (caddr (assoc 10 (entget s0))))  ;取出图元插入点的z坐标值
  24. ;从左到右,从上到下(reverse
  25. ;lst  ----要排序的图元集 FUZZ----允许偏差；若无为nil
  26. (defun xz-l2r (plist FUZZ / p1 p2)
  27. (setq plist (vl-sort plist  '(lambda (p1 p2)
  28.      ;(cond
  29.        (cond((> (+(xz-y p1)FUZZ) (xz-y p2)) T))
  30.        (cond((and (= (+(xz-y p1)FUZZ) (xz-y p2)) (< (+(xz-x p1)FUZZ) (xz-x p2))) T))
  31.        ;(cond((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T))
  32.        ;(T nil)
  33.      ;)
  34.    );lambda
  35. )))


  38. ;从上到下,从左到右
  39. ;lst  ----要排序的图元集 FUZZ----允许偏差；若无为nil (reverse
  40. (defun xz-u2d (plist FUZZ / p1 p2)
  41. (setq plist  (vl-sort plist  '(lambda (p1 p2)
  42.      (cond
  43.      ((> (+(xz-x p1)FUZZ) (xz-x p2)) T)
  44.      ((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (> (+(xz-y p1)FUZZ) (xz-y p2))) T)
  45.      ((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T)
  46.            (T nil)
  47.      )   
  48.    );lambda
  49. )))   
  50. ;******************************************************************************
  51. ;******************************************************************************
  52. ;******************************************************************************
  53. (defun c:pg (/ EP1 EG1 EG2 blktag EP1st blkname str GETK
  54.        index0 index sslist XZ_sortlist len0 len sslist-ptl index0)
  55.   (vl-load-com)
  56.   (if (progn
  57.      (setq EP1 (entsel"点取属性块中页码的位置:\n"))
  58.            (setq EG1 (cdr (assoc 0 (entget (car EP1)))))
  59.            (if (= EG1 "INSERT")
  60.                (progn (setq EG2 (car (nentselp (cadr EP1))))
  61.                    (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
  62.                  (setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
  63.        )
  64.              (setq EP1st (entget (car EP1)))
  65.              (setq blkname (assoc 2 EP1st))   
  66.          )
  67.     )
  68.         )
  69.    (princ (strcat"  块名为-->" (cdr blkname) "   标记为-->" blktag "\n"))
  70.          (progn(princ "  必须选择属性块!")(exit))
  71.    )
  72.   ;开始选择页码块并修改
  73.   (if (=  str0  nil) (setq str0 1)) (initget 6)
  74.   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0) ">:")))
  75.   (if (= str  nil)(setq str  str0))
  76.   
  77.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
  78.   (princ ">>选择批量修改页码的对象...")
  79.   (setq ss (ssget  (cons blkname slist)))
  80.   (setq index0 0 index (sslength ss) sslist '())   
  81.   (repeat index
  82.     (setq sslist (cons (ssname ss index0) sslist))
  83.     (setq index0 (1+ index0))
  84.   )
  85.   ;开始构建图元点位表
  86.   (setq index0 0  sslist-ptl '() tmp-pt '())   
  87.   (repeat index
  88.     (setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
  89.     (setq sslist-ptl (cons tmp-pt sslist-ptl))
  90.     (setq tmp-pt '())
  91.     (setq index0 (1+ index0))
  92.   )
  93.   ;开始排序
  94.   (cond      
  95.   ;从左到右从上到下
  96.   ((or (= GETK "H")(= GETK nil))
  97.     (setq XZ_sortlist (vl-sort
  98.       (vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
  99.       '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
  100.   )
  101.   ;从上到下从左到右
  102.   ((= GETK "V")
  103.     (setq XZ_sortlist (vl-sort
  104.       (vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
  105.       '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
  106.    )
  107.    ;选择顺序
  108.   ((= GETK "S")
  109.     (setq XZ_sortlist  sslist-ptl))
  110.    );cond
  111.   ;开始修改页码
  112.     (setq len0 0 len (length XZ_sortlist))
  113.     (repeat len
  114.      (if (setq ent0 (car (nth len0 XZ_sortlist)))
  115.    (progn (xz-att ent0 blktag str)
  116.                 (princ (strcat "-->正在修改页码 <" (rtos str) ">  "))
  117.           (setq len0 (1+ len0) str (1+ str))
  118.           (setq str0  str)
  119.    )
  120.       )
  121.   );repeat
  122.   (prin1)
  123. )
  124. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  125. (defun c:pginf ()
  126. (alert "                                           欢迎使用本程序\n
  127.          1.本程序为做越南万豪酒店施工图时所写.\n
  128.          2.本程序使用VisualLISP语言.\n
  129.          3.基于程序思想可以实现增加前缀及按页码打印,有空且心情好时再写.\n
  130.          4.本程序排序方法为属性块的插入点.\n
  131.          5.本程序通过ActiveX提取了属性块的标记而后修改相应的值.\n
  132.          6.程序已加密恕不提供源码.\n
  133.          7.如有疑问请自行保留.\n
  134.                                                                        ---by 李晓卓 2010.9.11
  135.                                                                        ---RTX:60315
  136.   ")(prin1)
  137.   )
  138. ;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  139. (princ "\n************************************************")
  140. (princ "\n**    批量改页码 pg.lsp已加载                 **")
  141. (princ "\n**      >>批量改页码,以pg启动命令             **")
  142. (princ "\n**      >>查看程序信息,以pginf启动命令        **")
  143. (princ "\n**                          ----by 李晓卓     **")
  144. (princ "\n**                              2010.9.11     **")
  145. (princ "\n************************************************")
  146. (princ)


本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

点评

我爱lisp
有心人，不易已  发表于 2017-8-29 15:07
半听可乐
程序非常好用！感谢分享！  发表于 2012-11-29 22:59

评分

参与人数 5明经币 +5 金钱 +30 收起 理由
bssurvey + 1 赞一个!
lidaxiu + 1 + 30 呵呵李工，居然才知道是同个公司的同事，支.
jfxia + 1 很给力!
1993063 + 1 赞一个!
xiaxiang + 1 感谢共享好程序！

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下

本帖被以下淘专辑推荐:

回复

使用道具 举报

shopping200
发表于 2017-12-27 09:18:25 | 显示全部楼层
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)   例子


  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)
回复 支持 3 反对 0

使用道具 举报

無恒的地盘
发表于 2011-9-3 21:48:43 | 显示全部楼层
本帖最后由 無恒的地盘 于 2011-9-3 22:12 编辑


429014673应该说的是这个意思吧,动态块好像不可以选。

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x
回复 支持 0 反对 1

使用道具 举报

gbhsu
发表于 2011-9-3 09:01:02 | 显示全部楼层
这么好的东东
大家顶哦
楼主真是大好!!!
回复 支持 反对

使用道具 举报

cnks
发表于 2011-9-3 09:16:04 | 显示全部楼层
顶你！放源码就是好兄弟
回复 支持 反对

使用道具 举报

429014673
发表于 2011-9-3 15:16:38 | 显示全部楼层
楼主可以改成M-1 M-2 M-3   .............
P-1  P-2  P-3  这种样式就好了(都是属性值来的)
回复 支持 反对

使用道具 举报

LLXXZZ
 楼主| 发表于 2011-9-3 21:19:10 | 显示全部楼层
429014673 发表于 2011-9-3 15:16
楼主可以改成M-1 M-2 M-3   .............
P-1  P-2  P-3  这种样式就好了(都是属性值来的)

没看明白你的意思.
懒得再改它了,尤其是页码的排序,其实可以做的更好,懒得弄.
根据需要自己来处理吧.
回复 支持 反对

使用道具 举报

LLXXZZ
 楼主| 发表于 2011-9-3 22:24:42 | 显示全部楼层
無恒的地盘 发表于 2011-9-3 21:48
429014673应该说的是这个意思吧,动态块好像不可以选。

动态块处理没做过.要补充代码才行,自己补吧.
回复 支持 反对

使用道具 举报

429014673
发表于 2011-9-4 09:45:40 来自手机 | 显示全部楼层
我那个是图号来的，不过和上面图片也差不多，图纸太多了要一个一个去修改要不少时间，呵呵，找这个程序一直没找到，不知有哪位高人帮忙改下(加入一个提示，点选属性文字，如M-…A-等，再提示页码起始值，如2，框选图框属性值会变为M-2,M-3)
回复 支持 反对

使用道具 举报

Nico
发表于 2011-9-4 10:22:59 | 显示全部楼层
我顶  
回复 支持 反对

使用道具 举报

andyding
发表于 2011-9-4 14:45:53 | 显示全部楼层
顶!放源码的都是我的哥！
回复 支持 反对

使用道具 举报

12345678910... 11下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-22 20:09 , Processed in 0.211619 second(s), 31 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表