文字齐线修改版
本帖最后由 vectra 于 2014-12-24 21:16 编辑支持单行及多行文字，直线及多段线，仅修改文字角度，对位置不做处理。
修改自 wzg356 http://bbs.mjtd.com/thread-112540-1-1.html
借用他人代码，不参加悬赏，故另开一贴
做标注程序时很有用的代码，发在这里做个备份。
(defun c:tt (/ picksegendpt en1 en2 enl1 enl2 p1 p1p2 p2 p3)
(defun picksegendpt (obj p / n)
(setq p (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj p))
)
(list (vlax-curve-getpointatparam obj n)
(vlax-curve-getpointatparam obj (1+ n))
)
)
(while
(not
(and
(setq en1 (entsel "\n选择单行或多行文字："))
(wcmatch (cdr (assoc 0 (setq enl1 (entget (car en1)))))
"*TEXT"
)
)
)
)
(while
(not
(wcmatch
(cdr
(assoc 0
(setq
enl2(entget
(car (setq en2 (entsel "\n选择要对齐的直线:")))
)
)
)
)
"*LINE"
)
)
)
(setq p3 (cadr en2))
(if (= (cdr (assoc 0 enl2)) "LINE")
(setq p1 (cdr (assoc 10 enl2))
p2 (cdr (assoc 11 enl2))
)
(setq p1p2 (picksegendpt (car en2) p3)
p1 (car p1p2)
p2 (cadr p1p2)
)
)
(if (<= (distance p3 p1) (distance p3 p2))
(setq enl1 (subst (cons 50 (angle p1 p2)) (assoc 50 enl1) enl1))
(setq enl1 (subst (cons 50 (angle p2 p1)) (assoc 50 enl1) enl1))
)
(entmod enl1)
(princ)
)
xiaobaixiaobu 发表于 2014-12-25 10:02 static/image/common/back.gif
要是能做到这样就好了！！
;;通用grread定义
(defun ZML-GRREAD (LST / TEST TMP MODE VAL TMP2)
(setq TEST t)
(while TEST
(setq TMP(grread 2)
MODE (car TMP)
VAL(cadr TMP)
)
(cond ((= MODE 2)
(if (and(setq TMP2 (assoc MODE LST))
(setq TMP2 (cdr TMP2))
(setq TMP2 (assoc VAL TMP2))
)
(eval (cons 'progn (cdr TMP2)))
()
)
)
((setq TMP2 (assoc MODE LST))
(eval (cons 'progn (cdr TMP2)))
)
(t (princ TMP))
)
)
)
;;;========================================================
;;;文字随线(角度随线的)
(vl-load-com)
(defun C:ts (/ tt-01 tt-02 LST)
;;===============
;;功能：计算计算距给定点位最近的线上点 和 线上点的前进方位角
;;参数：EN_LINE -----线的图元名称
;; PT -----给定点位
;;返回：距点最近的线上点 和 线上点的方位角
(defun TT-01 (EN_LINE PT / OBJ PT1 LST ANG)
;;将图元名转换为 VLA对象
(setq OBJ (vlax-ename->vla-object EN_LINE))
;;距pt最近的曲线上的点pt1
(setq PT1 (vlax-curve-getclosestpointto OBJ PT))
;;pt1点的切线方向矢量
(setq LST (vlax-curve-getfirstderiv
OBJ
(vlax-curve-getparamatpoint
OBJ
PT1
)
)
)
;;计算切线方位角
(setq ANG (atan (/ (cadr LST) (car LST))))
;;返回
(list PT1 ANG)
)
;;===============
;;功能：设置文字对象位置及角度
(defun TT-02 (EN_TEXT PT ANG / ENT)
(setq ENT (entget EN_TEXT))
(setq ENT (subst (cons 10 PT) (assoc 10 ENT) ENT)
ENT (subst (cons 11 PT) (assoc 11 ENT) ENT)
ENT (subst (cons 50 ANG) (assoc 50 ENT) ENT)
)
(entmod ENT)
)
;;===============
(if(and
;;
(setq SS (entsel "\n点取线: "))
(setq EN_LINE (car SS))
(setq ENT_LINE (entget EN_LINE))
(wcmatch (cdr (assoc 0 ENT_LINE))
"LINE,ARC,LWPOLYLINE,SPLINE"
)
;;
(setq SS (entsel "\n点取文字: "))
(setq EN_TEXT (car SS))
(setq ENT_TEXT (entget EN_TEXT))
(wcmatch (cdr (assoc 0 ENT_TEXT)) "TEXT,MTEXT")
)
(progn
(setq LST
(list '(5
;;
(setq
TMP
(TT-01 EN_LINE VAL)
PT1
(car TMP)
ANG
(cadr TMP)
)
;;
(TT-02 EN_TEXT VAL ANG)
(vlax-get-property (vlax-ename->vla-object EN_text) 'InsertionPoint )
;;
(redraw)
(grdraw VAL PT1 1)
)
;;左击
'
(3
(redraw)
(setq TEST NIL)
)
'(25
(redraw)
(setq TEST NIL)
)
'(11
(redraw)
(setq TEST NIL)
)
)
)
(ZML-GRREAD LST)
)
)
(princ)
)
看看这组代码是不是阁下想要的结果。
只对直线有效么？ 代码简洁易懂，十分感谢楼主 十分感谢楼主分享，多段线也能用~~ 要是能做到这样就好了！！ 不错，支持一下。 这个很不错，感谢分享 newbuser 发表于 2014-12-26 10:06
看看这组代码是不是阁下想要的结果。
目前我用过最好的文字齐线插件，谢谢，非常感谢，收藏。
页:
[1]
2