好东西，先顶了！
李工，因有旋转（即竖向）的图框，且块比例都不相同，但图框下端都在一水平线上，
所以排序时是否可以修改为以图框的左下角点进行排序？
参考了好多的排序函数，但都没顺利的修改出来，请有时间的时候帮忙修改下，谢谢！！
感谢分享。受益匪浅
感谢楼主 的确改页码 自动递增就更好
此程序有时会出现尾数出现（.0000）用的CAD是2008的，有时又不会出现，你能帮忙优化一下吗
谢谢楼主，支持下
顶你！放源码就是好兄弟。谢谢分享
yxl88168 发表于 2017-8-25 13:43
此程序有时会出现尾数出现（.0000）用的CAD是2008的，有时又不会出现，你能帮忙优化一下吗
;更改属性块标记tag所对应的值string
(defun xz-att (ent tag string / liST0 liST1 num blkref)
(vl-load-com)
(if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object ent))) "AcDbBlockReference")
(if (vla-Get-HasAttributes blkref)
(progn (setq liST0 (vlax-safearray->list(vlax-variant-value (vla-GetAttributes blkref))))
(setq liST1 (mapcar 'vla-Get-TagStringliST0))
(setq num (vl-position tag list1))
(vla-put-TextString (nth num liST0) string)
)
); endif
); endif
(prin1)
); enddefun
;(setqent(car (entsel))) 例子
;(xz-att ent "页码" 30) 例子
;******************************************************************************
;******************************************************************************
;******************************************************************************
(defun c:yema (/ EP1 EG1 EG2 blktag EP1st blkname str GETK prefix sttr
index0 index sslist XZ_sortlist len0 len sslist-ptl index0)
(vl-load-com)
(if (progn
(setq EP1 (entsel"点取属性块中页码的位置:\n"))
(setq EG1 (cdr (assoc 0 (entget (car EP1)))))
(if (= EG1 "INSERT")
(progn (setq EG2 (car (nentselp (cadr EP1))))
(if (= (cdr (assoc 0 (entget EG2))) "ATTRIB")
(setq blktag (cdr (assoc 2 (entget EG2)))) ;标记
)
(setq EP1st (entget (car EP1)))
(setq blkname (assoc 2 EP1st))
)
)
)
(princ (strcat"块名为-->" (cdr blkname) " 标记为-->" blktag "\n"))
(progn(princ "必须选择属性块!")(exit))
)
;开始选择页码块并修改
(setq prefix (getstring "请输入前缀:"))
(if (=str0nil) (setq str0 1)) (initget 6)
(setq str (getint (strcat "请输入一个起始整数<" (rtos str0 2 0) ">:")))
(if (= strnil)(setq strstr0))
(initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: <H> "))
(princ ">>选择批量修改页码的对象...")
(setq ss (ssget(cons blkname slist)))
(setq index0 0 index (sslength ss) sslist '())
(repeat index
(setq sslist (cons (ssname ss index0) sslist))
(setq index0 (1+ index0))
)
;开始构建图元点位表
(setq index0 0sslist-ptl '() tmp-pt '())
(repeat index
(setq tmp-pt (cons (nth index0 sslist) (cons (cdr(assoc 10 (entget (nth index0 sslist)))) tmp-pt)))
(setq sslist-ptl (cons tmp-pt sslist-ptl))
(setq tmp-pt '())
(setq index0 (1+ index0))
)
;开始排序
(cond
;从左到右从上到下
((or (= GETK "H")(= GETK nil))
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (> (cadadr s1) (cadadr s2))))
'(lambda (s3 s4) (if(equal (cadadr s3) (cadadr s4) 0.6)(< (caadr s3) (caadr s4))))))
)
;从上到下从左到右
((= GETK "V")
(setq XZ_sortlist (vl-sort
(vl-sort sslist-ptl '(lambda (s1 s2) (< (caadr s1) (caadr s2))))
'(lambda (s3 s4) (if(equal (caadr s3) (caadr s4) 0.6)(> (cadadr s3) (cadadr s4))))))
)
;选择顺序
((= GETK "S")
(setq XZ_sortlistsslist-ptl))
);cond
;开始修改页码
(setq len0 0 len (length XZ_sortlist))
(repeat len
(if (setq ent0 (car (nth len0 XZ_sortlist)))
(progn
(cond
((/= prefix "")
(if (=(strlen (rtos str))1)
(setq sttr (strcat prefix "0" (rtos str 2 0)))
(setq sttr (strcat prefix (rtos str 2 0)))
))
((= prefix "")(setq sttr(rtos str 2 0)))
);cond
(xz-att ent0 blktag sttr)
(princ (strcat "-->正在修改页码 <" (rtos str 2 0) ">"))
(setq len0 (1+ len0) str (1+ str))
(setq str0str)
)
)
);repeat
(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun c:pginf ()
(alert " 欢迎使用本程序\n
1.本程序为做越南万豪酒店施工图时所写.\n
2.本程序使用VisualLISP语言.\n
3.基于程序思想可以实现增加前缀(已增加)及按页码打印,有空且心情好时再写.\n
4.本程序排序方法为属性块的插入点.\n
5.本程序通过ActiveX提取了属性块的标记而后修改相应的值.\n
6.程序已加密恕不提供源码.\n
7.如有疑问请自行保留.\n
---by 李晓卓 2010.11.17
---RTX:60315
")(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ "\n************************************************")
(princ "\n** 批量改页码 pg.lsp已加载 **")
(princ "\n** >>批量改页码,以pg启动命令 **")
(princ "\n** >>查看程序信息,以pginf启动命令 **")
(princ "\n** ----by 李晓卓 **")
(princ "\n** 2010.11.17 **")
(princ "\n************************************************")
(princ)
太好了，找到相应的东西
shopping200 发表于 2017-12-27 09:18
谢谢您，我下来试一下，好久没上明经了，今天才看到