求---多个单行文字水平对齐 LISP
有没有。用LISP.把多个单行文字进行按点或线进行水平对齐的。。编辑文字经常遇到。请各位帮一帮。谢啦。。 用Vlisp写了一个;;;;文本水平对齐;;;by:lihuili 2009-12-22
(vl-load-com)
(defun c:txt_hor_Alignment (/ Ent Obj InsPt ss TxtList item text_InsPt NewInsPt)
(setq Ent (entsel "\n 选择要对齐的参考文本(位置不变的文本): "))
(if (and
Ent
(= (value 0 (entget (car Ent))) "TEXT")
(not (redraw (car Ent) 3))
)
(progn
(setq Obj (MakeX (car Ent)))
(if (= (vla-get-Alignment Obj) 0)
(setq InsPt (safearray-value
(variant-value (vla-get-InsertionPoint Obj))
)
)
(setq
InsPt (safearray-value
(variant-value (vla-get-TextAlignmentPoint Obj))
)
)
)
(prompt "\n选择其他与参考对齐的文本(要改变位置)!")
(if (setq ss (ssget '((0 . "TEXT"))))
(progn
(setq TxtList (ss->Objlist ss))
(foreach item TxtList
(if (= (vla-get-Alignment item) 0)
(setq text_InsPt
(safearray-value
(variant-value (vla-get-InsertionPoint item))
)
)
(setq text_InsPt
(safearray-value
(variant-value
(vla-get-TextAlignmentPoint item)
)
)
)
)
(setq
InsPt (list (car text_InsPt)
(cadr InsPt)
(caddr InsPt)
)
)
(setq NewInsPt (vlax-3d-point InsPt))
(if (= (vla-get-Alignment item) 0)
(vla-put-InsertionPoint item NewInsPt)
(vla-put-TextAlignmentPoint item NewInsPt)
)
(redraw (car Ent) 4)
)
)
)
)
)
(princ)
)
(defun VALUE (num ent /)
(cdr (assoc num ent))
)
(defun MakeX (entname)
(vlax-ename->vla-object entname)
)
(defun ss->Objlist (ss / RtnList temp1)
(while (setq temp1 (ssname ss 0))
(setq RtnList (cons (vlax-ename->vla-object temp1) RtnList))
(ssdel temp1 ss)
)
RtnList
)
我以前写过一个，可以X和Y向都可以选择用的，你看一下吧。
(defun c:tta(/ txtsel TXTSEL_Num basept basetxt xcoor_basept ycoor_basept txtmb
dokey i txti txtnew txti_pt xcoor_txti ycoor_txti txti_pt_new )
(princ "\n文本自动对齐!Design by Ahill!Copyright@2007\n")
(setvar "cmdecho" 0)
(princ "\n请选择欲对齐的文本实体(自动滤去非文字实体):")
(while (if
(SETQ txtsel (SSGET '((-4 . "<OR" )(0 . "TEXT") (0 . "MTEXT")(-4 . "OR>"))))
T
nil)
(SETQ TXTSEL_Num (sslength txtsel))
(if (not (setq basept (getpoint "\n点取对齐点<选取参照文字实体>: ")))
(progn
(princ "\n选取参照文字实体:")
(SETQ basetxt (SSGET '((-4 . "<OR" )(0 . "TEXT") (0 . "MTEXT")(-4 . "OR>"))))
(if (= (cdr (assoc 0 (entget (ssname basetxt 0)))) "MTEXT")
(progn
(setq basept (cdr (assoc 10 (entget (ssname basetxt 0)))))
)
(progn
(setq mb72 (cdr (assoc 72 (entget (ssname basetxt 0)))))
(setq mb73 (cdr (assoc 73 (entget (ssname basetxt 0)))))
(if (or (/= 0 mb72) (/= 0 mb73))
(setq basept (cdr (assoc 11 (entget (ssname basetxt 0)))))
)
(if (and (= 0 mb72) (= 0 mb73))
(setq basept (cdr (assoc 10 (entget (ssname basetxt 0))))) ;获取基准文字座标
)
)
)
)
)
(setq xcoor_basept (car basept))
(setq ycoor_basept (cadr basept))
(if (not (setq dokey (getint "\n输入对齐方向 <1>沿X方向对齐 / <2>沿Y方向对齐 <2>:")))
(setq dokey 2)
)
(setq i 0)
(repeat TXTSEL_Num
(setq txti (entget (ssname txtsel i)))
(setq mb72 (cdr (assoc 72txti )))
(setq mb73 (cdr (assoc 73txti )))
(if (and (or (/= 0 mb72) (/= 0 mb73)) (/= (cdr (assoc 0 txti)) "MTEXT"))
(progn
(setq txti_pt (cdr (assoc 11txti )))
(setq txtmb 11)
)
)
(if (or (and (= 0 mb72) (= 0 mb73)) (= (cdr (assoc 0 txti)) "MTEXT"))
(progn
(setq txti_pt (cdr (assoc 10 txti )))
(setq txtmb 10)
)
)
(setq xcoor_txti (car txti_pt))
(setq ycoor_txti (cadr txti_pt))
(if (= dokey 2)
(progn
(setq txti_pt_new (list xcoor_txti ycoor_basept (caddr txti_pt)))
)
)
(if (= dokey 1)
(progn
(setq txti_pt_new (list xcoor_basept ycoor_txti(caddr txti_pt)))
)
)
(setq txti_pt_new (cons txtmb (list (car txti_pt_new) (cadr txti_pt_new) (caddr txti_pt_new))))
(setq txti_pt (cons txtmb (list (car txti_pt) (cadr txti_pt) (caddr txti_pt))))
(setq txtnew (subst txti_pt_new txti_pt txti))
(entmod txtnew)
(setq i (+ 1 i))
)
(princ "\n请选择欲对齐的文本实体(自动滤去非文字实体):")
)
(setvar "cmdecho" 1)
(princ)
)
(princ "\n TTA:文本对齐!Design by Ahill!Copyright@2007")
<p>谢谢，两位兄台了。</p><p></p> 谢谢2位前辈的分享! 非常好，感谢分享
页:
[1]