源代码:批量改页码(加前缀)及提取属性块
本帖最后由 LLXXZZ 于 2011-9-4 14:58 编辑在这个网页中
http://bbs.mjtd.com/thread-64566-1-1.html
有哥们确实向我要了源码,可能有些兄弟确实想看代码.现在给贴出来.
代码一般.没什么大不了的.但也着实让不少同仁受益.
页码的排序的功能写的不好,有优化的空间,懒得改了.哥们儿根据自己的需要自己改.
;提取属性块标记TagString或对应的值TextString
;ent:图元名,opt:为T程序返回TextString的表,为nil返回标记TagString的表
(defun xz-att-g (ent opt / liST0 liSTt liSTg blkref a)
(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 liSTt (mapcar 'vla-Get-TagStringliST0))
(setq liSTg (mapcar 'vla-get-TextStringliST0))
)
); endif
); endif
(if opt (setq a liSTg) (setq a liSTt))
a
); enddefun
;(setqent(car (entsel))) 例子
;(xz-att-g ent t) (xz-att-g ent nil)例子
;******************************************************************************
;******************************************************************************
;******************************************************************************
(defun c:gat (/ EP1 blkname liSTt GETK ss index0 sslist tmp-pt sslist-ptl XZ_sortlist strlist
strlenlist0 nthx nthn strlenlist myentmk_line myentmk_text OSM BPM pt m)
(vl-load-com)
(while (not (setq EP1 (entsel"点取带属性的块:\n"))))
(if (= (vla-Get-ObjectName (setq blkref (vlax-Ename->vla-Object (car EP1)))) "AcDbBlockReference")
(if (vla-Get-HasAttributes blkref)
(progn
(setq blkname (assoc 2 (entget (car EP1))))
(setq liSTt (xz-att-g (car EP1) nil))
(princ (strcat"属性块 块名为--> " (cdr blkname) "\n"))
)
)
(progn(princ "必须选择属性块!")(exit))
)
;开始选择页码块并修改
(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
;计算表内每列字符最长长度存储在表strlenlist中
(setq strlist (mapcar'(lambda (x) (xz-att-g (car x) t)) XZ_sortlist))
(setq strlenlist0 (mapcar'(lambda (x) (mapcar 'strlenx)) strlist))
(setq nthx 0 nthn (length (car strlenlist0)))
(setq strlenlist nil)
(while (< nthx nthn)
(setq nth1 (vl-sort strlenlist0 '(lambda (s1 s2) (>= (nth nthx s1) (nth nthx s2)))))
(setq strlenlist (cons (nth nthx (car nth1)) strlenlist))
(setq nthx (1+ nthx))
)
(setq strlenlist (reverse strlenlist))
;____________________________
;生成图元子程序
(defun myentmk_line (pt1 pt2 );(起点(uCS) 终点(uCS) 图层 颜色)
(command "_.line" pt1 pt2 "")
)
;(myentmk_line (getpoint)(getpoint))
(defun myentmk_text (cont pt1);(内容 起点)
(if (not (= "" cont)) (command "_.text" "J" "ml" pt1 3.0 0.0 cont ));对齐点为左中
)
;(myentmk_text " " (getpoint))
;____________________________
;提取初始状态
(setvar "CMDECHO" 0)
(setq OSM (Getvar "OSMODE" ))
(setq BPM (Getvar "blipmode"))
(setvar "OSMODE"0)
(setvar "blipmode" 0)
;判断文字样式
(command "_.undo" "group")
;(if (tblsearch "style" "JHZX")
;(setvar "TEXTSTYLE" "JHZX")
;(command "-STYLE""JHZX""ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
(command "-STYLE""JHZX""ros.shx,hztxt.shx" 0 0.75 0 "n" "n" "n" )
;) ;设置字体样式JHZX为当前样式
;_____________________________________________
;绘制表格子程序
(defun drawtable (lis row pt / x0 yo len x1 n pta ptb)
(setq x0 (car pt) yo (cadr pt) len (length lis))
(setq charlen (apply '+ lis))
;画横线
(setqx1 (+(* 1.5 charlen) (car pt) (* 20 len)))
(setqn 0)
(repeat (+ row 2)
(setq pta (list x0 (- yo (* n 4))) ptb (list x1 (- yo (* n 4))))
(myentmk_line pta ptb)
(setqn (1+ n))
)
;画竖线
(myentmk_line pt (polar pt (* 1.5 pi) (* (1+ row) 4)));第一根竖线
(setqn 0 x1 x0)
(while (< n len)
(setqx1 (+(* 1.5 (nth n lis)) 20x1));第二根的x坐标n＝0
(setq pta (list x1 yo) ptb (polar pta (* 1.5 pi) (* (1+ row) 4)))
(myentmk_line pta ptb)
(setqn (1+ n))
)
)
;_____________________________________________
;_____________________________________________
;绘制文字子程序
(defun drawtext (strlist strlenlist pt / x0 x1 pta n )
;pt第一个字的起点左中对齐，strlenlist字符长度表
(setq x0 (car pt) yo (cadr pt) len (length strlenlist))
;按横向写字
(myentmk_text (nth 0 strlist) pt);第一个文字
(setqn 0 x1 x0)
(while (< n len)
(setqx1 (+(* 1.5 (nth n strlenlist)) 20x1));第二个文字的x坐标n＝0
(setq pta (list x1 yo) )
(myentmk_text (nth (1+ n) strlist) pta)
(setqn (1+ n))
)
)
;_____________________________________________
;开始绘制表格
(setvar "OSMODE" OSM)
(while (not(setq pt (getpoint "指定表格的左上点:"))))
(if pt (setvar "OSMODE"0))
(drawtable strlenlist index pt)
;表格中写上文字
(drawtext liSTt strlenlist (list (+ 10 (car pt)) (- (cadr pt) 2)));第一排为属性标记
(setq m 0)
(repeat (length strlist)
(setqpta (list (+ 10 (car pt)) (- (cadr pt) (* m 4) 6)))
(drawtext (nth m strlist) strlenlist pta)
(setq m (1+ m))
)
(command "_.undo" "end")
;还原初始状态
(setvar "OSMODE" OSM)
(setvar "blipmode"BPM)
(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(defun c:gatinf ()
(alert " 欢迎使用本程序\n
1.此程序以送别同仁肖俊，今日他离职了，此处留个记号以标记今天的这个特别的日子。\n
2.同时提醒自己： 一日不读则愚！\n
3.程序调用了cad的line与text命令，所以程序反应比较慢，主要是自己对enmake函数应用不精，
抓紧时间学习这个函数。使用此函数将提高程序运行速度！\n
---by 李晓卓 2011.3.14
---RTX:60315
")(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ "\n************************************************")
(princ "\n** 块属性提取 gat.lsp已加载 **")
(princ "\n** >>提取块属性,以gat启动命令 **")
(princ "\n** >>查看程序信息,以gatinf启动命令 **")
(princ "\n** ----by 李晓卓 **")
(princ "\n** 2011.3.14 **")
(princ "\n************************************************")
(princ)
;更改属性块标记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 xz-x (s0)(car (assoc 10 (entget s0)))) ;取出图元插入点的x坐标值
(defun xz-y (s0)(cadr (assoc 10 (entget s0))));取出图元插入点的y坐标值
(defun xz-z (s0)(caddr (assoc 10 (entget s0))));取出图元插入点的z坐标值
;从左到右,从上到下(reverse
;lst----要排序的图元集 FUZZ----允许偏差；若无为nil
(defun xz-l2r (plist FUZZ / p1 p2)
(setq plist (vl-sort plist'(lambda (p1 p2)
;(cond
(cond((> (+(xz-y p1)FUZZ) (xz-y p2)) T))
(cond((and (= (+(xz-y p1)FUZZ) (xz-y p2)) (< (+(xz-x p1)FUZZ) (xz-x p2))) T))
;(cond((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T))
;(T nil)
;)
);lambda
)))
;从上到下,从左到右
;lst----要排序的图元集 FUZZ----允许偏差；若无为nil (reverse
(defun xz-u2d (plist FUZZ / p1 p2)
(setq plist(vl-sort plist'(lambda (p1 p2)
(cond
((> (+(xz-x p1)FUZZ) (xz-x p2)) T)
((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (> (+(xz-y p1)FUZZ) (xz-y p2))) T)
((and (= (+(xz-x p1)FUZZ) (xz-x p2)) (= (+(xz-y p1)FUZZ) (xz-y p2))(> (+(xz-z p1)FUZZ) (xz-z p2))) T)
(T nil)
)
);lambda
)))
;******************************************************************************
;******************************************************************************
;******************************************************************************
(defun c:pg (/ EP1 EG1 EG2 blktag EP1st blkname str GETK
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))
)
;开始选择页码块并修改
(if (=str0nil) (setq str0 1)) (initget 6)
(setq str (getint (strcat "请输入一个起始整数<" (rtos str0) ">:")))
(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 (xz-att ent0 blktag str)
(princ (strcat "-->正在修改页码 <" (rtos str) ">"))
(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.9.11
---RTX:60315
")(prin1)
)
;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ "\n************************************************")
(princ "\n** 批量改页码 pg.lsp已加载 **")
(princ "\n** >>批量改页码,以pg启动命令 **")
(princ "\n** >>查看程序信息,以pginf启动命令 **")
(princ "\n** ----by 李晓卓 **")
(princ "\n** 2010.9.11 **")
(princ "\n************************************************")
(princ)
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) 本帖最后由 無恒的地盘 于 2011-9-3 22:12 编辑
429014673应该说的是这个意思吧,动态块好像不可以选。 这么好的东东
大家顶哦
楼主真是大好!!! 顶你！放源码就是好兄弟 楼主可以改成M-1 M-2 M-3 .............
P-1P-2P-3这种样式就好了(都是属性值来的) 429014673 发表于 2011-9-3 15:16 static/image/common/back.gif
楼主可以改成M-1 M-2 M-3 .............
P-1P-2P-3这种样式就好了(都是属性值来的)
没看明白你的意思.
懒得再改它了,尤其是页码的排序,其实可以做的更好,懒得弄.
根据需要自己来处理吧. 無恒的地盘 发表于 2011-9-3 21:48 static/image/common/back.gif
429014673应该说的是这个意思吧,动态块好像不可以选。
动态块处理没做过.要补充代码才行,自己补吧.
我那个是图号来的，不过和上面图片也差不多，图纸太多了要一个一个去修改要不少时间，呵呵，找这个程序一直没找到，不知有哪位高人帮忙改下(加入一个提示，点选属性文字，如M-…A-等，再提示页码起始值，如2，框选图框属性值会变为M-2,M-3) 我顶 顶!放源码的都是我的哥！