调整文字到引线上方并自动对齐

★飞飛★

2. 
   
3. ;;--------------------------------------------------------------------
   
4. ;; 程序功能：调整文字到引线上方并自动对齐
   
5. ;; 程序命令：ty
   
6. ;; 程序编写：★飞飛★  2012.8.12
   
7. ;; 注意事项：此程序使用前，请将左向引线标注的文字左对正，右向右对正。
   
8. ;;--------------------------------------------------------------------
   
9. (defun c:ty (/ selobjs ENT1 PT1 ss11 zss2 ENT2
   
10.              PT2 ss12 PT3 zg PT20 PT21 ss2 )
    
11.   (setq *error* nil)
    
12.   (setvar "cmdecho" 0)
    
13.   (princ "\n调整文字到引线位置，请选择文字和引线:")
    
14. (while (and
    
15.   (setq selobjs (ssget '((0 . "LEADER,*TEXT"))))
    
16.   (setq k 0)
    
17.   (setq  selobjs1 (ssadd)
    
18.   selobjs2 (ssadd)
    
19.   )
    
20.   (repeat (sslength selobjs)
    
21.     (setq en0  (ssname selobjs k)
    
22.     ent0 (entget en0)
    
23.     typ  (cdr (assoc 0 ent0))
    
24.     )
    
25.     (if  (= typ "LEADER")
    
26.       (setq selobjs1 (ssadd en0 selobjs1))
    
27.       (setq selobjs2 (ssadd en0 selobjs2))
    
28.     )
    
29.     (setq k (1+ k))
    
30.   ) ;repeat
    
31. ) ;and
    
32.   (setvar 'osmode 0)
    
33.     (setq ENT1 (entget (ssname selobjs1 0) )
    
34.     PT1 (assoc 10 (reverse ENT1) )
    
35.     PT11 (cdr PT1)
    
36.           ss11 (cadr PT11)
    
37.     )
    
38. 
    
39.     (setq zss2 (ssname selobjs2 0 )
    
40.           ENT2 (entget (ssname selobjs2 0) )
    
41.           PT2  (assoc 10 ENT2 )
    
42.           ss12 (cadr (cdr PT2 ))
    
43.     PT3 (assoc 40 ENT2 )
    
44.           zg (cdr PT3 )
    
45.     )
    
46. 
    
47.    (setq PT20 (cdr (assoc 11 ENT2 )) )
    
48.    (if (and (= 0 (car PT20)) (= 0 (cadr PT20)) )
    
49.        (setq PT21 (cdr PT2 ) )
    
50.        (setq PT21 PT20 )
    
51.    )
    
52. 
    
53.    (setq ss2 (polar PT11 (/ pi 2) (* zg 0.2) ))
    
54.    (if (and (= (car PT21) (car ss2)) (= (cadr PT21) (cadr ss2)) )
    
55.        (princ "所选对象已调整完成。")
    
56.        (command "move" zss2 "" PT21 ss2 )
    
57.    )
    
58.   (setvar 'osmode 6907)
    
59. ) ;while
    
60.   (setvar "cmdecho" 1)
    
61.   (princ)
    
62. )

<br /> ;;--------------------------------------------------------------------<br /> ;; 程序功能：调整文字到引线上方并自动对齐 <br /> ;; 程序命令：ty<br /> ;; 程序编写：★飞飛★  2012.8.12<br /> ;; 注意事项：此程序使用前，请将左向引线标注的文字左对正，右向右对正。<br /> ;;-------------------------------------------------------------------- <br /> (defun c:ty (/ selobjs ENT1 PT1 ss11 zss2 ENT2 <br />              PT2 ss12 PT3 zg PT20 PT21 ss2 )<br />   (setq *error* nil)<br />   (setvar "cmdecho" 0)<br />   (princ "\n调整文字到引线位置，请选择文字和引线:")<br /> (while (and<br />   (setq selobjs (ssget '((0 . "LEADER,*TEXT"))))<br />   (setq k 0)<br />   (setq  selobjs1 (ssadd)<br />   selobjs2 (ssadd)<br />   )<br />   (repeat (sslength selobjs)<br />     (setq en0  (ssname selobjs k)<br />     ent0 (entget en0)<br />     typ  (cdr (assoc 0 ent0))<br />     )<br />     (if  (= typ "LEADER")<br />       (setq selobjs1 (ssadd en0 selobjs1))<br />       (setq selobjs2 (ssadd en0 selobjs2))<br />     )<br />     (setq k (1+ k))<br />   ) ;repeat<br /> ) ;and<br />   (setvar 'osmode 0)<br />     (setq ENT1 (entget (ssname selobjs1 0) )<br />     PT1 (assoc 10 (reverse ENT1) )<br />     PT11 (cdr PT1)<br />           ss11 (cadr PT11)<br />     )<br /> <br />     (setq zss2 (ssname selobjs2 0 )<br />           ENT2 (entget (ssname selobjs2 0) )<br />           PT2  (assoc 10 ENT2 )<br />           ss12 (cadr (cdr PT2 ))<br />     PT3 (assoc 40 ENT2 )<br />           zg (cdr PT3 )<br />     )<br /> <br />    (setq PT20 (cdr (assoc 11 ENT2 )) )<br />    (if (and (= 0 (car PT20)) (= 0 (cadr PT20)) )<br />        (setq PT21 (cdr PT2 ) )<br />        (setq PT21 PT20 )<br />    )<br /> <br />    (setq ss2 (polar PT11 (/ pi 2) (* zg 0.2) ))<br />    (if (and (= (car PT21) (car ss2)) (= (cadr PT21) (cadr ss2)) )<br />        (princ "所选对象已调整完成。")<br />        (command "move" zss2 "" PT21 ss2 )<br />    )<br />   (setvar 'osmode 6907)<br /> ) ;while<br />   (setvar "cmdecho" 1)<br />   (princ)<br /> )

注：此程序能自动调整文字到引线上方并对齐，不足之处为只能两两选择（即一个文本对应一个引线同时选择），不能实现框选多重的文字和引线的最近捕捉搭配，这是个复杂的问题，自己很努力的去编写过但没能完成，望明经的高手们赐教！
提供思路：框选多重的文字和引线对象后，第一层循环为分别找出所有引线端点坐标，第二层循环为分别计算所有文本端点坐标，并用第1个文本的端点去一一匹配引线端点坐标，如文本端点Y坐标距某引线端点Y坐标为最小，则此文本与此引线配对；接着用第2个文本的端点去一一匹配引线端点坐标，如文本端点Y坐标距某引线端点Y坐标为最小，则此文本与此引线配对……如此循环下去，直到所有的文本与最近的引线配对完成后退出。

sx147

xyp1964 发表于 2012-8-26 08:47

这个看着很牛

xyp1964

無恒的地盘

(defun c:dqw ()
  (prompt "\n选择文字或属性块:")
  (setq ent (entsel "\n 选择:"))
  (setq ent1 (cdr (assoc 10 (entget (car ent)))))
  (prompt "\n选择引线:")
  (setq ent2 (vla-get-Coordinates (vlax-ename->vla-object (car (entsel)))))
  (setq ent2 (vlax-safearray->list (vlax-variant-value ent2)))
  (setq ent3 (repeat (- (length ent2) 3) (setq ent2 (cdr ent2))))
  (command ".copy" ent "" ent1 ent3)
)

我也是写了一个，不过也是只能两个对齐。

★飞飛★

文字调整前:                                          文字调整后:

fanqinwei

楼主，得考虑一下几行文字与一条线对齐时，如何使用。

★飞飛★

fanqinwei 发表于 2012-8-22 07:36
楼主，得考虑一下几行文字与一条线对齐时，如何使用。

通常引线标注的时候都是一行文字上引线上方或一行文字在上方一行文字在下方这两种情况的，如遇几行文字的情况就最好用另外一程序了。

vvcd

呵呵，顶一个，谢谢了

★飞飛★

xyp1964 发表于 2012-8-26 08:47

这个有点眼晕，可否上传一下原码，大家共同研究研究学习学习啊。

xyp1964

★飞飛★ 发表于 2012-8-27 13:57
这个有点眼晕，可否上传一下原码，大家共同研究研究学习学习啊。

;; 伪源码需要e派工具箱(XCAD)的支持，程序仅针对特殊的图层文字进行处理。