求助，请大神帮忙改一下文字齐线的小程序
在一个求助帖http://bbs.mjtd.com/forum.php?mod=viewthread&tid=99624&highlight=%CE%C4%D7%D6%2B%CF%DF里看到x_s_s_1这位大神写的一个文字齐线的程序，后来夏生生改过，觉得很好用，但只支持直线，不支持PL线，所以请哪位大神帮忙改进一下，使之能支持PL线，谢谢。另外请教怎么改成左对齐？;;;拷贝文字随线角度 by x_s_s_1@163.com
(defun c:ctb (/ ent enl pt1 pt2 mid_pt ang)
(defun emk_t (layer pt1 pt2 text ang n72 n73 h w sty /)
(entmake (list '(0 . "text")
'(100 . "AcDbEntity")
(cons 8 layer)
'(100 . "AcDbText")
(cons 10 pt1)
(cons 1 text)
(cons 40 h)
(cons 41 w)
(cons 7 sty)
(cons 72 n72)
(cons 11 pt2)
(cons 50 ang)
(cons 73 n73)
)
)
)
(while
(setq ent (car (entsel "\n选择文字：")))
(if (= "TEXT" (cdr (assoc 0 (entget ent))))
(progn
(while (setq enl (car (entsel "\n选择对齐线：")))
(if (= "LINE" (cdr (assoc 0 (entget enl))))
(progn
(setq pt1(cdr (assoc 10 (entget enl)))
pt2(cdr (assoc 11 (entget enl)))
mid_pt (mapcar '(lambda (x y) (/ (+ x y) 2)) pt2 pt1)
ang(angle pt1 pt2)
)
(if (and (> ang (* 0.5 pi)) (<= ang (* pi 1.5)))
(setq ang (- ang pi))
)
(emk_t (cdr (assoc 8 (entget ent)))
'(0 0 0)
(polar mid_pt (+ ang (* 0.5 pi)) 100)
(cdr (assoc 1 (entget ent)))
ang
1
0
(cdr (assoc 40 (entget ent)))
(cdr (assoc 41 (entget ent)))
(cdr (assoc 7 (entget ent)))
)
)
)
)
)
))
(princ)
)
大神们，都忙 (defun c:tt ()
;; tt(拷贝文字随线角度)
(if (and (setq s1 (car (entsel "\n选择文字: ")))
(xyp-Etype s1 "TEXT")
)
(progn
(redraw s1 3)
(while (and (setq e (entsel "\n选择对齐线: "))
(setq s2 (car e))
(xyp-curve-check s2)
(setq p0 (vlax-curve-getclosestpointto s2 (cadr e)))
(setq rad (xyp-Rad2Real (xyp-Get-AngleAtPoint s2 p0) 1))
)
;;(xyp-Cross p0 300 0)
(xyp-CopyMove s1 (xyp-9pt s1 5) p0)
(xyp-SubUpd (entlast) 50 rad)
)
(redraw s1 4)
)
)
(princ)
)
页:
[1]