文字与引线对齐

迹扬

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

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

---

Sring65

(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)
)

迹扬

源码如下：

1. (defun c:ttu(/ s1 s2 sstoes a b);|如果有两个文字距一个引线距离一样远，会移动最后写入的那个文字|;
   
2. 
   
3.   (defun SstoEs(ss / a en lst)
   
4. 
   
5.     (if ss(progn(setq a -1)
   
6. 
   
7.         (while(setq en(ssname ss(setq a(1+ a))))(setq lst(cons en lst)))))
   
8. 
   
9.     lst)
   
10. 
    
11.   (prompt "请选择引线和要移的文字")
    
12. 
    
13.   (setq s1(SstoEs(ssget'((0 . "LEADER,TEXT"))))s2'())
    
14. 
    
15.   (foreach a s1
    
16. 
    
17.     (if (=(vla-get-objectname(vlax-ename->vla-object a))"AcDbText")
    
18. 
    
19.       (setq s1(vl-remove a s1)s2(cons a s2))))
    
20. 
    
21.   (foreach a s1
    
22. 
    
23.     (if s2(entmod(setq p(cdr(assoc 10(entget a)))
    
24. 
    
25.          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)))
    
26. 
    
27.                    (list(distance(cdr q)p)q x))s2)'(lambda(x y)(<(car x)(car y)))))
    
28. 
    
29.          s2(vl-remove(caddr b)s2)
    
30. 
    
31.          b(subst(cons(caadr b)p)(cadr b)(entget(caddr b)))))))
    
32. 
    
33.   (princ)
    
34. 
    
35.   )

(defun c:ttu(/ s1 s2 sstoes a b);|如果有两个文字距一个引线距离一样远，会移动最后写入的那个文字|;<br /> <br />   (defun SstoEs(ss / a en lst)<br /> <br />     (if ss(progn(setq a -1)<br /> <br />         (while(setq en(ssname ss(setq a(1+ a))))(setq lst(cons en lst)))))<br /> <br />     lst)<br /> <br />   (prompt "请选择引线和要移的文字")<br /> <br />   (setq s1(SstoEs(ssget'((0 . "LEADER,TEXT"))))s2'())<br /> <br />   (foreach a s1<br /> <br />     (if (=(vla-get-objectname(vlax-ename->vla-object a))"AcDbText")<br /> <br />       (setq s1(vl-remove a s1)s2(cons a s2))))<br /> <br />   (foreach a s1<br /> <br />     (if s2(entmod(setq p(cdr(assoc 10(entget a)))<br /> <br />          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)))<br /> <br />                    (list(distance(cdr q)p)q x))s2)'(lambda(x y)(<(car x)(car y)))))<br /> <br />          s2(vl-remove(caddr b)s2)<br /> <br />          b(subst(cons(caadr b)p)(cadr b)(entget(caddr b)))))))<br /> <br />   (princ)<br /> <br />   )

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

Sring65

(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)
)

迹扬

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

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

迹扬

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

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

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

Sring65

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

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

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

冒个烟圈

Sring65 发表于 2014-12-7 19:26
可以先调整好了再运行吧？

先试试，嘿嘿。。

leimw

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

juliana207

可以帮忙吧MTEXT 改为MTEXT吗?