本帖最后由 LLXXZZ 于 2011-9-4 14:58 编辑

在这个网页中

http://bbs.mjtd.com/thread-64566-1-1.html

有哥们确实向我要了源码,可能有些兄弟确实想看代码.现在给贴出来.

代码一般.没什么大不了的.但也着实让不少同仁受益.

页码的排序的功能写的不好,有优化的空间,懒得改了.哥们儿根据自己的需要自己改.

[code="lisp]

;提取属性块标记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-TagString  liST0))

(setq liSTg (mapcar 'vla-get-TextString  liST0))

)

); endif

); endif

(if opt (setq a liSTg) (setq a liSTt))

a

); enddefun

;(setq  ent  (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)]: "))

(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 0  sslist-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_sortlist  sslist-ptl))

);cond

;计算表内每列字符最长长度存储在表strlenlist中

(setq strlist (mapcar  '(lambda (x) (xz-att-g (car x) t)) XZ_sortlist))

(setq strlenlist0 (mapcar  '(lambda (x) (mapcar 'strlen  x)) 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))

;画横线

(setq  x1 (+(* 1.5 charlen) (car pt) (* 20 len)))

(setq  n 0)

(repeat (+ row 2)

(setq pta (list x0 (- yo (* n 4))) ptb (list x1 (- yo (* n 4))))

(myentmk_line pta ptb)

(setq  n (1+ n))

)

;画竖线

(myentmk_line pt (polar pt (* 1.5 pi) (* (1+ row) 4)));第一根竖线

(setq  n 0 x1 x0)

(while (< n len)

(setq  x1 (+(* 1.5 (nth n lis)) 20  x1));第二根的x坐标n＝0

(setq pta (list x1 yo) ptb (polar pta (* 1.5 pi) (* (1+ row) 4)))

(myentmk_line pta ptb)

(setq  n (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);第一个文字

(setq  n 0 x1 x0)

(while (< n len)

(setq  x1 (+(* 1.5 (nth n strlenlist)) 20  x1));第二个文字的x坐标n＝0

(setq pta (list x1 yo) )

(myentmk_text (nth (1+ n) strlist) pta)

(setq  n (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)

(setq  pta (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)[/code][code="lisp]

;更改属性块标记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-TagString  liST0))

(setq num (vl-position tag list1))

(vla-put-TextString (nth num liST0) string)

)

); endif

); endif

(prin1)

); enddefun

;(setq  ent  (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 (=  str0  nil) (setq str0 1)) (initget 6)

(setq str (getint (strcat "请输入一个起始整数:")))

(if (= str  nil)(setq str  str0))

(initget "H V S ")(setq GETK (getkword "排序方式:\n [横向优先(H)/竖向优先(V)/选择优先(S)]: "))

(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 0  sslist-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_sortlist  sslist-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 "-->正在修改页码   "))

(setq len0 (1+ len0) str (1+ str))

(setq str0  str)

)

)

);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)[/code]