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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 批改图框页码，选择集排序疑问
12下一页
返回列表 发新帖
查看: 4564|回复: 15

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

[复制链接]
ㄘ丶转裑ㄧ灬
发表于 2018-7-19 20:53:05 | 显示全部楼层 |阅读模式
本帖最后由 ㄘ丶转裑ㄧ灬 于 2018-7-19 20:57 编辑

各位好，附件为LXZ老师批改图框页码的源码，对于做幕墙施工画加工图来说作用很大，
但排序一直是个问题，只能麻烦些一排一排改，不然顺序会错乱。
试过拿各种排序源码去修改，奈何水平不足，一直达不到想要的效果，
所以只能发帖请教各位老师，希望有时间能指点下，谢谢！！








  1. ;;;;批量改图框页码
  2. ;byLXXZZ
  3. ;http://bbs.mjtd.com/thread-89140-1-1.html
  4. ;更改属性块标记tag所对应的值string
  5. (defun xz-att (ent tag string / liST0 liST1 num blkref)
  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 liST1 (mapcar 'vla-Get-TagString  liST0))
  11.              (setq num (vl-position tag list1))
  12.              (vla-put-TextString (nth num liST0) string)
  13.   )
  14.     ); endif
  15.   ); endif
  16.   (prin1)
  17. ); enddefun
  18. ;(setq  ent  (car (entsel)))   例子
  19. ;(xz-att ent "页码" 30)   例子

  21. ;***********
  22. (defun c:YM (/ 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(princ "\n必须选择属性块.")(exit)(princ))
  30.              (progn (setq EG2 (car (nentselp (cadr EP1))))
  31.                    (if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
  32.                  (setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
  33.        )
  34.              (setq EP1st (entget (car EP1)))
  35.              (setq blkname (assoc 2 EP1st))
  36.          )
  37.          )
  38.          )
  39.         (princ (strcat "  块名为:" (cdr blkname) "   标记为:" blktag "\n"))
  40.          (progn(princ "  必须选择属性块!")(exit))
  41.          )        
  42.   
  43.   ;开始选择页码块并修改
  44.   (setq prefix (getstring "请输入前缀:"))
  45.   (if (=  str0  nil) (setq str0 1)) (initget 6)
  46.   (setq str (getint (strcat "请输入一个起始整数<" (rtos str0 2 0) ">:")))
  47.   (if (= str  nil)(setq str  str0))
  48.   
  49.   (initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
  50.   (princ ">>选择批量修改页码的对象...")
  51.   (setq ss (ssget  (cons blkname slist)))
  52.   (setq index0 0 index (sslength ss) sslist '())   
  53.   (repeat index
  54.     (setq sslist (cons (ssname ss index0) sslist))
  55.     (setq index0 (1+ index0))
  56.   )
  57.   ;开始构建图元点位表
  58.   (setq index0 0  sslist_ptl '() tmp_pt '())   
  59.   (repeat index
  60.     (setq tmp_pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp_pt)))
  61.     (setq sslist_ptl (cons tmp_pt sslist_ptl))
  62.     (setq tmp_pt '())
  63.     (setq index0 (1+ index0))
  64.   )
  65.   ;开始排序
  66.   (cond      
  67.   ;从左到右从上到下
  68.   ((or (= GETK "H")(= GETK nil))
  69.     (setq XZ_sortlist (vl-sort
  70.       (vl-sort sslist_ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
  71.       '(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))   
  72.   )
  73.   ;从上到下从左到右
  74.   ((= GETK "V")
  75.     (setq XZ_sortlist (vl-sort
  76.       (vl-sort sslist_ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
  77.       '(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))   
  78.    )
  79.    ;选择顺序
  80.   ((= GETK "S")
  81.     (setq XZ_sortlist  sslist_ptl))
  82.    );cond
  83.   ;开始修改页码
  84.     (setq len0 0 len (length XZ_sortlist))
  85.     (repeat len
  86.      (if (setq ent0 (car (nth len0 XZ_sortlist)))
  87.    (progn
  88.      (cond
  89.        ((/= prefix "")
  90.      (if (=(strlen (rtos str))1)
  91.        (setq sttr (strcat prefix "0" (rtos str 2 0)))
  92.        (setq sttr (strcat prefix (rtos str 2 0)))
  93.      ))
  94.        ((= prefix "")(setq sttr  (rtos str 2 0)))
  95.      );cond
  96.      (xz-att ent0 blktag sttr)
  97.      (princ (strcat " >>已修改至页:" (rtos str 2 0) "、"))
  98.      (setq len0 (1+ len0) str (1+ str))
  99.      (setq str0  str)      
  100.    )
  101.       )
  102.   );repeat
  103.   (prin1)
  104. )

本帖子中包含更多资源

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

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

使用道具 举报

xvjiex
发表于 2020-1-15 09:25:51 | 显示全部楼层
这应该是你要的。
  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)   例子

  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.   )


  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.   )




  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. )


点评

ㄘ丶转裑ㄧ灬
非常感谢，是我想要的排序，谢谢！！  发表于 2020-1-15 11:16
回复 支持 1 反对 0

使用道具 举报

ㄘ丶转裑ㄧ灬
 楼主| 发表于 2018-7-20 08:47:57 | 显示全部楼层
死神去了 发表于 2018-7-20 08:13
这个使用上完全没问题，排序是按照块的基点位置上下左右为判断依据的。。。
楼主的图框基点在横线位置就不 ...

是的，但公司的图框基本都在块的左下角，一旋转就难搞了，
属性块后期改基点又会把块里的属性移位，所以很烦~~！
回复 支持 反对

使用道具 举报

死神去了
发表于 2018-7-20 08:13:43 | 显示全部楼层
本帖最后由 死神去了 于 2018-7-20 08:22 编辑

这个使用上完全没问题，排序是按照块的基点位置上下左右为判断依据的。。。
楼主的图框基点在横线位置就不会出错的
回复 支持 反对

使用道具 举报

dong20030432
发表于 2018-7-20 11:35:49 | 显示全部楼层
用getboundingbox获取块图框的包围框，取左下角点进行排序试一下，应该可以。
回复 支持 反对

使用道具 举报

852456
发表于 2018-8-11 19:48:24 | 显示全部楼层
看帖回帖是美德
回复 支持 反对

使用道具 举报

kongel
发表于 2018-9-15 12:38:09 | 显示全部楼层
(setq tmp_pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp_pt)))

把这个改成

(setq tmp-pt (cons (nth index0 sslist) (cons (vlax-safearray->list  minpoint) tmp-pt)))
回复 支持 反对

使用道具 举报

涛涛_1048
发表于 2018-9-15 22:37:28 | 显示全部楼层
研究了半天，终于把选择优先放到前边了。有点笨了。
回复 支持 反对

使用道具 举报

bai2000
发表于 2018-9-17 11:25:44 | 显示全部楼层
楼上的，把改后的东西传上来啊
回复 支持 反对

使用道具 举报

依然小小鸟
发表于 2019-7-9 10:25:24 | 显示全部楼层
顶起来   希望更多人解决
回复 支持 反对

使用道具 举报

hn10183051
发表于 2019-9-25 10:55:42 | 显示全部楼层
改页码？怎么没有后缀 页  
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2025-2-22 02:03 , Processed in 0.225415 second(s), 32 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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