文字与引线对齐

迹扬发表于 2014-11-29 23:45:55

看过 llsheng_73 写的文字移动到圆心的程序，原文在http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108268

我想是不是可以改成文字移动到引线（LEADER）末端，请高手出手！

Sring65 发表于 2014-11-29 23:45:56

(defun c:ttu (/ s1 s2 sstoes a b GetLeaderLastPoint h w)
      ;|如果有两个文字距一个引线距离一样远，会移动最后写入的那个文字
from http://bbs.mjtd.com/thread-112275-1-1.html
2014-11-30 update by Sring65|;

(VL-LOAD-COM)
(defun GetLeaderNearTextPoint (x a / pt ptl ang)
(setq txt (entget x))
(setq a (REVERSE(entget a)))
(while (/= 10 (caar a))
   (setq a (cdr a))
)
(setq p (cdar a))
(if (EQUAL '(11 0 0 0)
      (assoc 11 txt)
)
   (setq q (assoc 10 txt))
   (setq q (assoc 11 txt))
)
(setq dis (distance (cdr q) p))
(setq ang (angle p (cdadr a)))
(setq ptl (last (textbox txt)))
(setq n72 (cdr (assoc 72 txt)))
(setq n73 (cdr (assoc 73 txt)))

(if (or (<= ang (/ pi 2)) (> ang (* pi 1.5)))
   (progn (cond ((= n72 2)
   (setq w 0)
   )
   ((= n72 1)
   (setq w -0.5)
   )
   (t (setq w -1))
      )
      (cond ((= n73 2)
   (setq h 0)
   )
   ((= n73 3)
   (setq h -0.5)
   )
   (t (setq h 0.5))
      )
   )
   (progn (cond ((= n73 2)
   (setq h 0)
   )
   ((= n73 3)
   (setq h 0.5)
   )
   (t (setq h -0.5))
      )
      (cond ((= n72 2)
   (setq w -1)
   )
   ((= n72 1)
   (setq w -0.5)
   )
   (t (setq w 0))
      )
   )
)
(setq p (POLAR p ang (* (car ptl) w)))
(setq p (POLAR p (- ang (/ pi 2)) (* (cadr ptl) h)))
(list dis q x p)
)
(defun SstoEs (ss / a en lst)
(if ss
   (progn (setq a -1)
      (while (setq en (ssname ss (setq a (1+ a))))
      (setq lst (cons en lst))
      )
   )
)
lst
)
(prompt "请选择引线和要移的文字")
(setq s1 (SstoEs (ssget '((0 . "LEADER,TEXT"))))
s2 '()
)
(foreach a s1
(if (= (vla-get-objectname (vlax-ename->vla-object a))
   "AcDbText"
)
   (setq s1 (vl-remove a s1)
   s2 (cons a s2)
   )
)
)
(foreach a s1
(if s2
   (entmod
(setq b (car (vl-sort
(mapcar
   '(lambda (x)
      (GetLeaderNearTextPoint x a)
   )
   s2
)
'(lambda (x y) (< (car x) (car y)))
      )
)
      s2 (vl-remove (caddr b) s2)
      b (subst (cons (caadr b) (last b))
(cadr b)
(entget (caddr b))
)
)
   )
)
)
(princ)
)

迹扬发表于 2014-11-29 23:48:17

源码如下：

(defun c:ttu(/ s1 s2 sstoes a b);|如果有两个文字距一个引线距离一样远，会移动最后写入的那个文字|;

(defun SstoEs(ss / a en lst)

(if ss(progn(setq a -1)

   (while(setq en(ssname ss(setq a(1+ a))))(setq lst(cons en lst)))))

lst)

(prompt "请选择引线和要移的文字")

(setq s1(SstoEs(ssget'((0 . "LEADER,TEXT"))))s2'())

(foreach a s1

(if (=(vla-get-objectname(vlax-ename->vla-object a))"AcDbText")

   (setq s1(vl-remove a s1)s2(cons a s2))))

(foreach a s1

(if s2(entmod(setq p(cdr(assoc 10(entget a)))

      b(car(vl-sort(mapcar'(lambda(x)(setq b(entget x)q(if(equal'(11 0 0 0)(assoc 11 b))(assoc 10 b)(assoc 11 b)))

               (list(distance(cdr q)p)q x))s2)'(lambda(x y)(<(car x)(car y)))))

      s2(vl-remove(caddr b)s2)

      b(subst(cons(caadr b)p)(cadr b)(entget(caddr b)))))))

(princ)

)

文字是与引线的起点对齐，求高手修改成文字与引线末端对齐

Sring65 发表于 2014-11-30 14:47:00

(defun c:ttu (/ s1 s2 sstoes a b GetLeaderLastPoint h w)
      ;|如果有两个文字距一个引线距离一样远，会移动最后写入的那个文字
from http://bbs.mjtd.com/thread-112275-1-1.html
2014-11-30 update by Sring65|;

(VL-LOAD-COM)
(defun GetLeaderNearTextPoint (x a / pt ptl ang)
(setq txt (entget x))
(setq a (entget a))
(while (/= 10 (caar a))
   (setq a (cdr a))
)
(setq p (cdar a))
(if (EQUAL '(11 0 0 0)
      (assoc 11 txt)
)
   (setq q (assoc 10 txt))
   (setq q (assoc 11 txt))
)
(setq dis (distance (cdr q) p))
(setq ang (angle p (cdadr a)))
(setq ptl (last (textbox txt)))
(setq n72 (cdr (assoc 72 txt)))
(setq n73 (cdr (assoc 73 txt)))

(if (or (<= ang (/ pi 2)) (> ang (* pi 1.5)))
   (progn (cond ((= n72 2)
   (setq w 1)
   )
   ((= n72 1)
   (setq w 0.5)
   )
   (t (setq w 0))
      )
      (cond ((= n73 2)
   (setq h 0)
   )
   ((= n73 3)
   (setq h -0.5)
   )
   (t (setq h 0.5))
      )
   )
   (progn (cond ((= n73 2)
   (setq h 0)
   )
   ((= n73 3)
   (setq h 0.5)
   )
   (t (setq h -0.5))
      )
      (cond ((= n72 2)
   (setq w 0)
   )
   ((= n72 1)
   (setq w 0.5)
   )
   (t (setq w 1))
      )
   )
)
(setq p (POLAR (cdadr a) ang (* (car ptl) w)))
(setq p (POLAR p (- ang (/ pi 2)) (* (cadr ptl) h)))
(list dis q x p)
)
(defun SstoEs (ss / a en lst)
(if ss
   (progn (setq a -1)
      (while (setq en (ssname ss (setq a (1+ a))))
      (setq lst (cons en lst))
      )
   )
)
lst
)
(prompt "请选择引线和要移的文字")
(setq s1 (SstoEs (ssget '((0 . "LEADER,TEXT"))))
s2 '()
)
(foreach a s1
(if (= (vla-get-objectname (vlax-ename->vla-object a))
   "AcDbText"
)
   (setq s1 (vl-remove a s1)
   s2 (cons a s2)
   )
)
)
(foreach a s1
(if s2
   (entmod
(setq b (car (vl-sort
(mapcar
   '(lambda (x)
      (GetLeaderNearTextPoint x a)
   )
   s2
)
'(lambda (x y) (< (car x) (car y)))
      )
)
      s2 (vl-remove (caddr b) s2)
      b (subst (cons (caadr b) (last b))
(cadr b)
(entget (caddr b))
)
)
   )
)
)
(princ)
)

迹扬发表于 2014-11-30 15:07:47

Sring65 发表于 2014-11-30 14:47 static/image/common/back.gif
(defun c:ttu (/ s1 s2 sstoes a b GetLeaderLastPoint h w)
;|如果有两个文字距一个引线距离一样远 ...

测试不成功，引线一般都是2个、3个或者更多顶点。现在文字移动的位置不是终点

迹扬发表于 2014-11-30 17:19:59

Sring65 发表于 2014-11-29 23:45 static/image/common/back.gif
(defun c:ttu (/ s1 s2 sstoes a b GetLeaderLastPoint h w)
;|如果有两个文字距一个引线距离一样远 ...

比较不错了，是我要的。非常感谢！

唯一有一些不足的是文字的对齐方式如果用JUSTIFYTEXT中的 ML 和MR 调整一下就更完美了

Sring65 发表于 2014-12-7 19:26:06

迹扬发表于 2014-11-30 17:19 static/image/common/back.gif
比较不错了，是我要的。非常感谢！

唯一有一些不足的是文字的对齐方式如果用JUSTIFYTEXT中的 ML 和M ...

可以先调整好了再运行吧？

冒个烟圈 发表于 2015-5-23 19:42:54

Sring65 发表于 2014-12-7 19:26 static/image/common/back.gif
可以先调整好了再运行吧？

先试试，嘿嘿。。

leimw 发表于 2018-10-28 15:52:37

为什么线不能选择，只能选择文本？

juliana207 发表于 2020-9-26 23:56:42

可以帮忙吧MTEXT 改为MTEXT吗?

页: [1]

明经CAD社区's Archiver

文字与引线对齐