求贱人工具箱里【文字表格居中】程序源码
贱人工具箱里【文字表格居中】程序源码，类似也行，使用方法就是框选单行文字，然后文字自动在所处的格子内居中 我这边有一个，可以用。(vl-load-com)
(defun c:WZJZh(/ err)
(defun algion (msg / ss lst i vlalstboxlstx
cor1 cor2 findboxpt newboxpt en1
en enlst y y2
)
(princ msg)
(setq ss (ssget '((0 . "text"))))
(setq lst nil)
(setq i 0)
(repeat (sslength ss)
(setq lst (cons (ssname ss i) lst))
(setq i (1+ i))
)
(setq vlalst (mapcar 'vlax-ename->vla-object lst))
(setq boxlst (mapcar '(lambda (x / cor1 cor2)
(vla-GetBoundingBox x 'cor1 'cor2)
(list (vlax-safearray->list cor1)
(vlax-safearray->list cor2)
)
)
vlalst
)
)
(setq
findboxpt (mapcar '(lambda (x)
(polar (car x)
(angle (car x) (cadr x))
(/ (DISTANCE (car x) (cadr x)) 2.0)
)
)
boxlst
)
)
(setq newboxpt (mapcar '(lambda (x)
(setq en1 (entlast))
(vl-cmdf "_boundary" x "")
(setq en (entlast))
(if (not (equal en1 en))
(progn
(setq enlst (entget en))
(setq lst (vl-remove-if-not
'(lambda (y) (= (car y) 10))
enlst
)
)
(setq cor1 (vl-remove 10 (car lst))
cor2 (vl-remove 10 (nth 2 lst))
)
(entdel en)
(polar cor1
(angle cor1 cor2)
(/ (DISTANCE cor1 cor2) 2.0)
)
)
)
)
findboxpt
)
)
(mapcar '(lambda (x y y2)
(vla-move x (vlax-3d-point y) (vlax-3d-point y2))
)
vlalst
findboxpt
newboxpt
)
)
(setq err(VL-CATCH-ALL-APPLY 'algion (list "\n选择文字: ")))
(princ)
) 嗯，试了下，可以用！ (vl-load-com)
(defun c:JZ(/ err)
(defun algion (msg / ss lst i vlalstboxlstx
cor1 cor2 findboxpt newboxpt en1
en enlst y y2
)
(princ msg)
(setq ss (ssget '((0 . "text"))))
(setq lst nil)
(setq i 0)
(repeat (sslength ss)
(setq lst (cons (ssname ss i) lst))
(setq i (1+ i))
)
(setq vlalst (mapcar 'vlax-ename->vla-object lst))
(setq boxlst (mapcar '(lambda (x / cor1 cor2)
(vla-GetBoundingBox x 'cor1 'cor2)
(list (vlax-safearray->list cor1)
(vlax-safearray->list cor2)
)
)
vlalst
)
)
(setq
findboxpt (mapcar '(lambda (x)
(polar (car x)
(angle (car x) (cadr x))
(/ (DISTANCE (car x) (cadr x)) 2.0)
)
)
boxlst
)
)
(setq newboxpt (mapcar '(lambda (x)
(setq en1 (entlast))
(vl-cmdf "_boundary" x "")
(setq en (entlast))
(if (not (equal en1 en))
(progn
(setq enlst (entget en))
(setq lst (vl-remove-if-not
'(lambda (y) (= (car y) 10))
enlst
)
)
(setq cor1 (vl-remove 10 (car lst))
cor2 (vl-remove 10 (nth 2 lst))
)
(entdel en)
(polar cor1
(angle cor1 cor2)
(/ (DISTANCE cor1 cor2) 2.0)
)
)
)
)
findboxpt
)
)
(mapcar '(lambda (x y y2)
(vla-move x (vlax-3d-point y) (vlax-3d-point y2))
)
vlalst
findboxpt
newboxpt
)
)
(setq err(VL-CATCH-ALL-APPLY 'algion (list "\n师兄 选择单行文字: ")))
(princ)
) ;;表格文字居中
(princ "\n飞诗CAD-表格文字居中 1.0，支持Text,Mtext。")
(defun c:mid_table_text
(/ *error* cen cmd h hobj la nss objs pt ss v vars w)
(princ "\n选择要居中的文本:")
(setq ss (ssget '((0 . "*text"))))
(or ss (fsxm-silenceexit))
(setq v '("cmdecho" "fillmode" "hpname" "hpassoc"))
(setq vars (mapcar 'getvar v))
(defun *error* (msg)
(foreach obj objs (vla-put-Visible obj 1))
(mapcar 'setvar v vars)
(vla-EndUndoMark *doc*)
(princ msg)
)
(vla-StartUndoMark *doc*)
(mapcar 'setvar v '(0 0 "SOLID" 0))
(setq nss (ssadd))
(setq objs (mapcar 'vlax-ename->vla-object (fsxm-ss->enlist ss)))
(foreach obj objs (vla-put-Visible obj 0))
(if (getcname "-hatch")
(setq cmd ".-hatch")
(setq cmd ".-boundary")
)
(foreach obj objs
(if (= (vla-get-ObjectName obj) "AcDbMText")
(progn
(setq w (vla-get-Width obj))
(vla-put-Width obj 0)
(setq pt (apply 'fsxm-midpt (fsxm-obj-box obj)))
(vla-put-Width obj w)
)
(setq pt (apply 'fsxm-midpt (fsxm-obj-box obj)))
)
(setq la (entlast))
(command cmd (trans pt 0 1) "")
(while (/= 0 (getvar "cmdactive")) (command))
(vla-put-Visible obj 1)
(setq h (entlast))
(if (/= h la) ;生成了剖面线
(progn
(setq hobj (vlax-ename->vla-object h))
(setq cen (apply 'fsxm-midpt (fsxm-obj-box hobj)))
(mapcar 'entdel (fsxm-newenlist la))
(vlax-invoke obj 'move pt cen)
(ssadd (vlax-vla-object->ename obj) nss)
)
)
)
(*error* (strcat "\n执行完成！共处理文字<"
(itoa (sslength ss))
">个，成功<"
(itoa (sslength nss))
">个..."
)
)
;;(sssetfirst nil nss)
(princ)
) 石井鱼 发表于 2012-7-13 11:56 static/image/common/back.gif
我这边有一个，可以用。
(vl-load-com)
(defun c:WZJZh(/ err)
运行结果有CAD提示：BOUNDARY 已创建 1 个多段线，怎么回事？而且感觉程序运行有点慢 本帖最后由 xyp1964 于 2012-7-13 13:10 编辑
;; 文字表格居中 伪源码需要e派工具箱(XCAD)的支持
(defun c:tt ()
(CMDLA0)
(setq ss (ssget '((0 . "TEXT")))
i-1
)
(while (setq s1 (ssname ss (setq i (1+ i))))
(xyp-Table-JustifyText s1 0 1)
)
(CMDLA1)
)
hao3ren 发表于 2012-7-13 12:42 static/image/common/back.gif
;;表格文字居中
(princ "\n飞诗CAD-表格文字居中 1.0，支持Text,Mtext。")
(defun c:mid_table_text
这个我用不了~~ xyp1964 发表于 2012-7-13 13:07 static/image/common/back.gif
用不了，给个全的吧 xyp1964 发表于 2012-7-13 13:07 static/image/common/back.gif
院长威武，但院长的函数库太大了，让人敬而远之。