图纸目录函数，原函数默认图号在上，图名在下，是否可以实现图号在下，图名在上
图纸目录函数，原函数默认图号在上，图名在下，是否可以实现图号在下，图名在上，与一般的单位图框编制一样？
;;;====================================
;;;PEACE zhptj1986@gmail.com
;;;http://blog.sina.com.cn/peacelvirene
;;;ZIAD浙江省建筑设计研究院
;;;===============================
;;;图纸目录整理(必须图框中图号在上，图名在下才可用;先执行选择-再执行整理)
;;;命令：PEACE-DwgList
;;;by PEACE 2013/09/12 V1.0
;;;===============================
(vl-load-com)
(defun c:PEACE-DwgList( /
;局部函数
*error*
PEACE:StoreSysVarCAD
PEACE:RestoreSysVarCAD
PEACE:SaveSysVarPeace
PEACE:ReadSysVarPeace
PEACE:Fsxm-ssget
SaveSysVar
GETDATA
;局部变量
vcmde vblip vclay vosmo vplwd vlupr vdelo vtsty ;系统变量
dclname tempname filen stream dcl_re
stylelist style stylen layerlist layer layern qzlist qzn
textss tn textdata texti texth dwgn tp1 tp2 findl tmtextss
dwglist tm i j textj p1 p2 t1 t2 tmlist texty
;全局变量
)
;局部函数开始
;自定义错误处理函数
(defun *error* (msg)
(PEACE:RestoreSysVarCAD) ;还原系统变量
(command ".UNDO" "E")
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)
;储存系统变量
(defun PEACE:StoreSysVarCAD()
(setq vcmde (getvar "cmdecho"));普通命令的提示
(setq vblip (getvar "blipmode")) ;光标痕迹
(setq vclay (getvar "CLAYER")) ;图层
(setq vosmo (getvar "osmode")) ;捕捉模式
(setq vplwd (getvar "plinewid")) ;pl宽度
(setq vlupr (getvar "luprec")) ;长度精度
(setq vdelo (getvar "delobj")) ;控制创建面域时是否保留原pline，0为保留，1为不保留
(setq vtsty (getvar "textstyle"))
)
;还原系统变量
(defun PEACE:RestoreSysVarCAD()
(setvar "cmdecho" vcmde)
(setvar "blipmode" vblip)
(setvar "CLAYER" vclay)
(setvar "osmode" vosmo)
(setvar "plinewid" vplwd)
(setvar "luprec" vlupr)
(setvar "delobj" vdelo)
(setvar "textstyle" vtsty)
)
;保存peace系统变量
(defun PEACE:SaveSysVarPeace(valname valvalue infotext / acadpath f datalist data valvalue_old i isthere)
(setq acadpath(vlax-get-property (vlax-get-acad-object) 'Path))
(if (= infotext "")(setq infotext "no infotext"))
(if (null (findfile "PEACESYSVAL.TXT"))
(progn ;若文件不存在
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "w"))
(prin1 (list valname valvalue infotext) f)
(close f)
)
(progn ;若文件已存在
(setq datalist '())
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "r"))
(while (setq data (read-line f))
(setq datalist (cons data datalist))
)
(close f)
(setq datalist (reverse datalist))
(setq i 0
isthere 0)
(repeat (length datalist)
(if (= valname (car (read (nth i datalist))))
(progn
(setq datalist (subst (vl-prin1-to-string (list valname valvalue infotext)) (nth i datalist) datalist))
(setq isthere 1)
)
)
(setq i (1+ i))
)
(if (= 1 isthere)
(progn
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "w"))
(prin1 (read (nth 0 datalist)) f)
(close f)
(setq i 1)
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "a"))
(repeat (- (length datalist) 1)
(write-line "" f)
(prin1 (read (nth i datalist)) f)
(setq i (1+ i))
)
(close f)
)
(progn
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "a"))
(write-line "" f)
(prin1 (list valname valvalue infotext) f)
(close f)
)
)
)
)
(princ)
)
;读取peace系统变量
(defun PEACE:ReadSysVarPeace( / acadpath data datalist i f)
(setq acadpath(vlax-get-property (vlax-get-acad-object) 'Path))
(if (findfile "PEACESYSVAL.TXT")
(progn
(setq datalist '())
(setq f (open (strcat acadpath "\\PEACESYSVAL.TXT") "r"))
(while (setq data (read-line f))
(setq datalist (cons data datalist))
)
(reverse datalist)
(close f)
(setq i 0)
(repeat (length datalist)
(set (read (car (read (nth i datalist)))) ;注意字符和表之间的转换，字符串是不能作为变量名的
(cadr (read (nth i datalist))) ;car对字符串也是不起作用的
)
(setq i (1+ i))
)
)
nil
)
)
;;带关键字的ssget
;;Msg=提示信息，Kwd=关键字，Fil=条件
;示例：(PEACE:Fsxm-ssget "\n请选择一个圆：" "F" '((0 . "circle")))
(defun PEACE:Fsxm-ssget (Msg Kwd Fil / Kwd0 pt var *acad* *doc*)
(setq *acad* (vlax-get-acad-object))
(setq *doc* (vla-get-ActiveDocument *acad*))
;===内部函数开始===
;;带过滤器的entsel
(defun Fsxm-entsel (msg filter)
(setq enp (entsel msg))
(if (or (= (type enp) 'str)
(and enp (ssget (cadr enp) filter))
)
enp
)
)
;;;用分隔符解释字符串成表
(defun Fsxm-Split (string strkey / po strlst xlen)
(setq xlen (1+ (strlen strkey)))
(while (setq po (vl-string-search strkey string))
(setq strlst (cons (substr string 1 po) strlst))
(setq string (substr string (+ po xlen)))
)
(reverse (cons string strlst))
)
;;点化字串
(defun Fsxm-Pt2Str (pt)
(strcat (rtos (car pt) 2 2)
","
(rtos (cadr pt) 2 2)
","
(rtos (caddr pt) 2 2)
"\n"
)
)
;===内部函数结束===
(cond
((cadr (ssgetfirst)))
(T
(setq Kwd0 "W L C BOX ALL F WP CP G A R M P U AU SI")
(initget (strcat Kwd0 " " kwd))
(cond ((and (listp (setq var (Fsxm-entsel Msg Fil)))
(/= 52 (getvar "errno"))
)
(vla-sendcommand *doc* (Fsxm-Pt2Str (cadr (grread t))))
(ssget Fil)
)
((member var (Fsxm-Split Kwd0 " "))
(vla-sendcommand *doc* (strcat var "\n"))
(ssget Fil)
)
(t var)
)
)
)
)
;;;由左下点PA和右上点PB得到矩形的9个特征点 by peace 2013/08/29
;;;左下点开始依次为p0 p1...中心点为p8
(defun PEACE:Point_9pt (pa pb / p0 P1 P2 P3 P4 P4 P5 P6 P7 P8)
(setq p0 (list (car pa) (cadr pa))
p4 (list (car pb) (cadr pb))
p2 (list (car p4) (cadr p0))
p6 (list (car p0) (cadr p4))
p1 (list (* 0.5 (+ (car p0)(car p2)))(* 0.5 (+ (cadr p0)(cadr p2))))
p3 (list (* 0.5 (+ (car p2)(car p4)))(* 0.5 (+ (cadr p2)(cadr p4))))
p5 (list (* 0.5 (+ (car p4)(car p6)))(* 0.5 (+ (cadr p4)(cadr p6))))
p7 (list (* 0.5 (+ (car p0)(car p6)))(* 0.5 (+ (cadr p0)(cadr p6))))
p8 (list (* 0.5 (+ (car p0)(car p4)))(* 0.5 (+ (cadr p0)(cadr p4))))
)
(list p0 p1 p2 p3 p4 p5 p6 p7 p8)
)
;;;由pt1根据Δx\Δy\Δz得到pt2by PEACE 2013/07/06
;;;对于二维点和三维点均适用，二维点时dz不起作用
(defun PEACE:Point_Offset (pt1 dx dy dz / x y z pt2)
(setq x (+ (car pt1) dx)
y (+ (cadr pt1) dy)
)
(if (= (length PT1) 3)
(setq z (+ (caddr pt1) dz)
pt2 (list x y z)
)
(setq pt2 (list x y))
)
pt2
)
;来源http://bbs.mjtd.com/thread-9546-1-1.html[提供者：aeo000000]
;(PEACE:Sort_xy li '(>))只按x由大到小
;(PEACE:Sort_xy li '(<))只按x由小到大
;(PEACE:Sort_xy li '(nil >)) 只按y由大到小
;(PEACE:Sort_xy li '(nil <)) 只按y由小到大
;其余x和y组合的情况类推
(defun PEACE:Sort_xy (li how / a)
(if(setq a(car how))(setq li(vl-sort li '(lambda(x y)((eval a)(car x)(car y))))))
(if(setq a(cadr how))(setq li(vl-sort li '(lambda(x y)((eval a)(cadr x)(cadr y))))))
li
)
;保存变量
(defun SaveSysVar()
(PEACE:SaveSysVarPeace "P1309:DWGL_BZ" P1309:DWGL_BZ "PEACE-DwgList步骤")
(PEACE:SaveSysVarPeace "P1309:DWGL_QZ" P1309:DWGL_QZ "PEACE-DwgList图号前缀")
(PEACE:SaveSysVarPeace "P1309:DWGL_FW" P1309:DWGL_FW "PEACE-DwgList搜索范围")
(PEACE:SaveSysVarPeace "P1309:DWGL_H" P1309:DWGL_H "PEACE-DwgList字高")
(PEACE:SaveSysVarPeace "P1309:DWGL_D" P1309:DWGL_D "PEACE-DwgList行距")
(PEACE:SaveSysVarPeace "P1309:DWGL_C" P1309:DWGL_C "PEACE-DwgList颜色")
(PEACE:SaveSysVarPeace "P1309:DWGL_S" P1309:DWGL_S "PEACE-DwgList样式")
(PEACE:SaveSysVarPeace "P1309:DWGL_L" P1309:DWGL_L "PEACE-DwgList图层")
)
;获取数据
(defun GETDATA()
(setq P1309:DWGL_QZ (get_tile "ea201"))
(setq P1309:DWGL_FW (atof (get_tile "ea203")))
(setq P1309:DWGL_H (atof (get_tile "ea301")))
(setq P1309:DWGL_D (atof (get_tile "ea302")))
(setq P1309:DWGL_C (atof (get_tile "ea303")))
(setq P1309:DWGL_S (get_tile "ea304"))
(setq P1309:DWGL_L (get_tile "ea306"))
)
;局部函数结束
;主函数开始
(PEACE:StoreSysVarCAD);储存系统变量
(PEACE:ReadSysVarPeace) ;读取peace系统变量
(setvar "cmdecho" 0)
(command ".UNDO" "BE")
(if (not P1309:DWGL_BZ)(setq P1309:DWGL_BZ 1));步骤
(if (not P1309:DWGL_FW)(setq P1309:DWGL_FW 4));搜索范围
(if (not P1309:DWGL_H)(setq P1309:DWGL_H 350));文字高度
(if (not P1309:DWGL_D)(setq P1309:DWGL_D 200));文字间距
(if (not P1309:DWGL_C)(setq P1309:DWGL_C 2));文字颜色
(setq stylelist '())
(vlax-for style
(vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object)))
(setq stylelist(cons (vla-get-name style) stylelist))
)
(setq stylelist (acad_strlsort stylelist))
(setq layerlist '())
(vlax-for layer
(vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(setq layerlist(cons (vla-get-name layer) layerlist))
)
(setq layerlist (acad_strlsort layerlist))
(setq qzlist (list "结施-" "结初-" "建施-" "建初-"))
(if (not P1309:DWGL_S)(setq P1309:DWGL_S (nth 0 stylelist)));文字样式
(if (not P1309:DWGL_L)(setq P1309:DWGL_L (nth 0 layerlist)));文字图层
(if (not P1309:DWGL_QZ)(setq P1309:DWGL_QZ (nth 0 qzlist)));图号前缀
(if (not (setq stylen (vl-position P1309:DWGL_S stylelist))) (setq stylen 0))
(if (not (setq layern (vl-position P1309:DWGL_L layerlist))) (setq layern 0))
(if (not (setq qzn (vl-position P1309:DWGL_QZ qzlist))) (setq qzn 0))
(setq dclname
(cond
((setq tempname (vl-filename-mktemp "PEACEDCL.dcl")
filen (open tempname "w")
)
(foreach stream
'("\n" "dcl01:dialog {\n"
" label=\"图纸目录\"; \n"
" :boxed_row{label=\"选择步骤\"; \n"
" :radio_button{label=\"选取\";key=\"ea101\";mnemonic=\"1\";value=1; }\n"
" :radio_button{label=\"整理\";key=\"ea102\";mnemonic=\"2\"; }\n"
" } \n"
" :boxed_row{label=\"搜索设置\"; \n"
" :column{ \n"
" :edit_box{label=\"图号前缀\";key=\"ea201\";width=10;height=1.0;} \n"
" :popup_list{key=\"ea202\";edit_width=17;height=1.0;} \n"
" :row{ \n"
" :edit_box{label=\"搜索范围\";key=\"ea203\";width=5;height=1.0; }\n"
" :text{label=\"倍字高\" ; } \n"
" } \n"
" } \n"
" } \n"
" :boxed_row{label=\"书写设置\"; \n"
" :column{ \n"
" :edit_box{label=\"文字字高\";key=\"ea301\";width=10;height=1.0;} \n"
" :edit_box{label=\"净行间距\";key=\"ea302\";width=10;height=1.0;} \n"
" :edit_box{label=\"文字颜色\";key=\"ea303\";width=10;height=1.0;} \n"
" :edit_box{label=\"文字样式\";key=\"ea304\";width=10;height=1.0;} \n"
" :popup_list{key=\"ea305\";edit_width=17;height=1.0;} \n"
" :edit_box{label=\"文字图层\";key=\"ea306\";width=10;height=1.0;} \n"
" :popup_list{key=\"ea307\";edit_width=17;height=1.0;} \n"
" } \n"
" } \n"
" ok_cancel;"
" }"
)
(princ stream filen)
)
(close filen)
tempname
)
)
)
(setq dcl_re (load_dialog dclname))
(if (not (new_dialog "dcl01" dcl_re))
(exit)
)
(mode_tile "accept" 2)
(cond
((= P1309:DWGL_BZ 1) (set_tile "ea101" "1"))
((= P1309:DWGL_BZ 2) (set_tile "ea102" "1"))
)
(start_list "ea202")
(mapcar 'add_list qzlist)
(end_list)
(start_list "ea305")
(mapcar 'add_list stylelist)
(end_list)
(start_list "ea307")
(mapcar 'add_list layerlist)
(end_list)
(set_tile "ea201" P1309:DWGL_QZ)
(set_tile "ea202" (rtos qzn 2 0))
(set_tile "ea203" (rtos P1309:DWGL_FW 2 2))
(set_tile "ea301" (rtos P1309:DWGL_H 2 2))
(set_tile "ea302" (rtos P1309:DWGL_D 2 2))
(set_tile "ea303" (rtos P1309:DWGL_C 2 0))
(set_tile "ea304" P1309:DWGL_S)
(set_tile "ea305" (rtos stylen 2 0))
(set_tile "ea306" P1309:DWGL_L)
(set_tile "ea307" (rtos layern 2 0))
(action_tile "ea101" "(setq P1309:DWGL_BZ 1)")
(action_tile "ea102" "(setq P1309:DWGL_BZ 2)")
(action_tile "ea202" "(setq qzn $value)(setq P1309:DWGL_QZ (nth (atoi qzn) qzlist))(set_tile \"ea201\" P1309:DWGL_QZ)")
(action_tile "ea305" "(setq stylen $value)(setq P1309:DWGL_S (nth (atoi stylen) stylelist))(set_tile \"ea304\" P1309:DWGL_S)")
(action_tile "ea307" "(setq layern $value)(setq P1309:DWGL_L (nth (atoi layern) layerlist))(set_tile \"ea306\" P1309:DWGL_L)")
(action_tile "accept" "(GETDATA)(SaveSysVar)(done_dialog)")
(action_tile "cancel" "(done_dialog)")
(start_dialog)
(unload_dialog dcl_re)
(vl-file-delete dclname)
(setq textss (PEACE:Fsxm-ssget "\n>>> 请选择图号和图名<退出>：" " " (list '(0 . "*TEXT"))))
(cond
(
(or (= textss nil)(= textss ""))
(princ "\n*** 程序退出!")
)
(
t
(setq i 0 tn (strlen P1309:DWGL_QZ) dwglist '())
(cond
((= tn 0)(princ "\n*** 目前必须设置图号前缀! 程序退出!"))
(t
(repeat (sslength textss)
(setq textdata (entget (ssname textss i))
texti (cdr (assoc 1 textdata))
texth (cdr (assoc 40 textdata))
)
(if (= (substr texti 1 tn) P1309:DWGL_QZ)
(progn
(cond
( ;选取
(= P1309:DWGL_BZ 1)
(vla-GetBoundingBox (vlax-ename->vla-object (ssname textss i)) 'cor1 'cor2)
(setq dwgn (atoi (substr texti (1+ tn)))
tp1 (nth 0 (PEACE:Point_9pt (vlax-safearray->list cor1) (vlax-safearray->list cor2)))
findl (* P1309:DWGL_FW texth)
tp2 (PEACE:Point_Offset tp1 findl (- findl) 0)
tmtextss (ssget "C" tp1 tp2)
)
)
( ;整理
(= P1309:DWGL_BZ 2)
(vla-GetBoundingBox (vlax-ename->vla-object (ssname textss i)) 'cor1 'cor2)
(setq dwgn (atoi (substr texti (1+ tn)))
tp1 (nth 2 (PEACE:Point_9pt (vlax-safearray->list cor1) (vlax-safearray->list cor2)))
findl (* P1309:DWGL_FW texth)
tp2 (PEACE:Point_Offset tp1 findl (* 0.5 texth) 0)
tmtextss (ssget "C" tp1 tp2)
)
)
)
(if (= (sslength tmtextss) 0)
(setq tm "**未找到图名**")
(progn
(setq j 0 tm "" tmlist '())
(repeat (sslength tmtextss)
(if (not (equal (ssname textss i) (ssname tmtextss j)))
(if (vl-position (cdr (assoc 0 (entget (ssname tmtextss j)))) (list "TEXT" "MTEXT"))
(progn
(vla-GetBoundingBox (vlax-ename->vla-object (ssname tmtextss j)) 'cor1 'cor2)
(setq textj (cdr (assoc 1 (entget (ssname tmtextss j))))
texty (cadr (nth 0 (PEACE:Point_9pt (vlax-safearray->list cor1) (vlax-safearray->list cor2))))
tmlist (cons (list texty textj) tmlist)
)
)
)
)
(setq j (1+ j))
)
(setq tmlist (PEACE:Sort_xy tmlist '(>)) j 0)
(repeat (length tmlist)
(if (= tm "")
(setq tm (cadr (nth j tmlist)))
(setq tm (strcat tm "、" (cadr (nth j tmlist))))
)
(setq j (1+ j))
)
)
)
(setq dwglist (cons (list dwgn texti tm) dwglist))
)
)
(setq i (1+ i))
)
(setq dwglist (PEACE:Sort_xy dwglist '(<)))
)
)
(setq p1 (getpoint "\n>>> 指定书写基准点[右上角点]:"))
(setq i 0)
(repeat (length dwglist)
(setq p1 (PEACE:Point_Offset p1 0 (- (+ P1309:DWGL_H P1309:DWGL_D)) 0)
p2 (PEACE:Point_Offset p1 (* 6 P1309:DWGL_H) 0 0)
t1 (nth 1 (nth i dwglist))
t2 (nth 2 (nth i dwglist))
)
(entmake (list '(0 . "TEXT")
(cons 62 (atoi (rtos P1309:DWGL_C 2 0)))
(cons 72 0)
(cons 73 1)
(cons 8 P1309:DWGL_L)
(cons 7 P1309:DWGL_S)
(cons 1 t1)
(cons 10 p1)
(cons 11 p1)
(cons 40 P1309:DWGL_H)
(cons 41 0.8)
(cons 50 0)
))
(entmake (list '(0 . "TEXT")
(cons 62 (atoi (rtos P1309:DWGL_C 2 0)))
(cons 72 0)
(cons 73 1)
(cons 8 P1309:DWGL_L)
(cons 7 P1309:DWGL_S)
(cons 1 t2)
(cons 10 p2)
(cons 11 p2)
(cons 40 P1309:DWGL_H)
(cons 41 0.8)
(cons 50 0)
))
(setq i (1+ i))
)
(princ "\n*** 图纸目录生成完成!")
)
)
(command ".UNDO" "E")
(PEACE:RestoreSysVarCAD)
(princ)
)
(princ)
我去，这么多笑脸，上lsp吧 能上动图吗？ 属性块图框，图名、图号选不上 如果可以上一个测试文件就好了 不会用真着急。 上传一个动图介绍下怎么用吧 选不上，完全选不上啊 上下文字对应的DXF10 11互换一下不就上下文字反过来了。
页:
[1]