求个文字的复制并平行直线的程序
本帖最后由 baiyier1112 于 2012-12-16 00:05 编辑求个lisp程序：如图，将文字“皮带机中心线”连续复制到箭头所指位置，并让文字与直线平行。
注意：复制后原文字要保留
改改还可以这样，完成一个文字的拷贝，右键，再选择另一个文字操作
;;;拷贝文字随线角度 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)
)
最好是框选，一下拷到线的中心，并支持自定义与线的距离 本帖最后由 x_s_s_1 于 2012-12-16 10:51 编辑
试试合用否
;;;拷贝文字随线角度 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)
)
)
)
(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)
)
tssd好像可以吧 本帖最后由 baiyier1112 于 2012-12-15 22:50 编辑
用探索者实现，需要2步操作：
第一步，复制文字到一个位置
第二步：用探索者的文字平行命令。
我想要一个命令完成：即将以上的两步用一个命令完成
搜索吧！记得G版帮人搞过一个！ http://bbs.mjtd.com/thread-89922-1-1.html yjr111 发表于 2012-12-15 23:23 static/image/common/back.gif
http://bbs.mjtd.com/thread-89922-1-1.html
谢谢。这个程序很好，我希望达到的目的是复制并将复制出的文字与线平行。原有的字要留下。 x_s_s_1 发表于 2012-12-16 10:51 static/image/common/back.gif
试试合用否
非常合适，万分感谢。
有个小请求，不知大侠能否将程序改进一下，将复制后的文字放到指定位置，而不单纯是线段的中点处。 baiyier1112 发表于 2012-12-16 11:19 static/image/common/back.gif
非常合适，万分感谢。
有个小请求，不知大侠能否将程序改进一下，将复制后的文字放到指定位置，而不单纯 ...
我自己用倾向于放置于中心点，按照您的要求修改了一下，皮带一般都是用line线画的，所以没有对其它线条图元进行处理
;;;拷贝文字随线角度 by x_s_s_1@163.com
(vl-load-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)
)
)
)
(setq ent (car (entsel "\n选择文字：")))
(if (= "TEXT" (cdr (assoc 0 (entget ent))))
(progn
(while (setq enl (entsel "\n选择对齐线："))
(if (= "LINE" (cdr (assoc 0 (entget (car enl)))))
(progn
(setq pt1(cdr (assoc 10 (entget (car enl))))
pt2(cdr (assoc 11 (entget (car enl))))
mid_pt (vlax-curve-getClosestPointTo
(vlax-ename->vla-object (car enl))
(cadr enl)
)
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)
)