大家谁帮着写一个把带圈数字移动到最近端点的lisp

waa21301

如题,大家谁帮着写一个把带圈数字移动到最近端点的lisp。

cdma2546

首先，想对楼主说一句话，起码的谢谢要有吧，谁也不欠你的....
其次呢，你应该说明你的对象是 带圆的文字 还是块  还有就是那个是直线还是多段线...
正确的描述才能得到所需的帮助！

434939575

2. (defun c:tt (/);靠近圆和圆内文字移动到两线没有相交的端点
   
3.   (prompt "选择图形")
   
4.   (setq app nil)
   
5.   (setq ss (ssget))
   
6.   (command "select" ss "")
   
7.   (setq ss-line (ssget "p" '((0 . "*LINE"))))
   
8.   (setq na-1 (ssname ss-line 0))
   
9.   (setq pta (vlax-curve-getstartpoint na-1))
   
10.   (setq ptb (vlax-curve-getendpoint na-1))
    
11.   (setq na-2 (ssname ss-line 1))
    
12.   (setq ptaa (vlax-curve-getstartpoint na-2))
    
13.   (setq ptbb (vlax-curve-getendpoint na-2))
    
14.   (if (equal pta ptaa 5)
    
15.     (setq lis (list ptb ptbb))
    
16.     (progn
    
17.       (if (equal pta ptbb 5)
    
18.         (setq lis (list ptb ptaa))
    
19.         (progn
    
20.           (if (equal ptb ptaa 5)
    
21.             nil
    
22.             (setq lis (list pta ptaa))
    
23.           )
    
24.         )
    
25.       )
    
26.     )
    
27.   )
    
28.   (setq        lis (vl-sort lis
    
29.                      (function (lambda (e1 e2)
    
30.                                  (< (car e1) (car e2))
    
31.                                )
    
32.                      )
    
33.             )
    
34.   )
    
35.   (command "select" ss "")
    
36.   (setq ss-CIRCLE (ssget "p" '((0 . "CIRCLE"))))
    
37.   (setq ii 0)
    
38.   (repeat (sslength ss-CIRCLE)
    
39.     (setq name (ssname ss-CIRCLE ii)
    
40.           ii   (1+ ii)
    
41.           cen  (cdr (assoc 40 (entget name)))
    
42.     )
    
43.     (setq app (append (list (append (list cen) (list name))) app))
    
44.   )
    
45.   (setq        app (vl-sort app
    
46.                      (function (lambda (e1 e2)
    
47.                                  (< (car e1) (car e2))
    
48.                                )
    
49.                      )
    
50.             )
    
51.   )
    
52.   (mapcar '(lambda (x y)
    
53.              (vl-cmdf "move"
    
54.                       (sss (cadr y))
    
55.                       ""
    
56.                       (cdr (assoc 10 (entget (cadr y))))
    
57.                       x
    
58.              )
    
59.            )
    
60.           lis
    
61.           app
    
62.   )
    
63. )
    
64. (defun sss (na / cen en pt- pt+ pt< pt> rad ss)
    
65.   (setq en (entget na))
    
66.   (setq rad (cdr (assoc 40 en)))
    
67.   (setq cen (cdr (assoc 10 en)))
    
68.   (setq pt> (polar cen 0 (1+ rad)))
    
69.   (setq pt< (polar cen pi (1+ rad)))
    
70.   (setq pt+ (polar cen (* 0.5 pi) (1+ rad)))
    
71.   (setq pt- (polar cen (* 1.5 pi) (1+ rad)))
    
72.   (setq ss (ssget "cp" (list pt> pt+ pt< pt-)))
    
73. )

(defun c:tt (/);靠近圆和圆内文字移动到两线没有相交的端点<br />   (prompt "选择图形")<br />   (setq app nil)<br />   (setq ss (ssget))<br />   (command "select" ss "")<br />   (setq ss-line (ssget "p" '((0 . "*LINE"))))<br />   (setq na-1 (ssname ss-line 0))<br />   (setq pta (vlax-curve-getstartpoint na-1))<br />   (setq ptb (vlax-curve-getendpoint na-1))<br />   (setq na-2 (ssname ss-line 1))<br />   (setq ptaa (vlax-curve-getstartpoint na-2))<br />   (setq ptbb (vlax-curve-getendpoint na-2))<br />   (if (equal pta ptaa 5)<br />     (setq lis (list ptb ptbb))<br />     (progn<br />       (if (equal pta ptbb 5)<br />         (setq lis (list ptb ptaa))<br />         (progn<br />           (if (equal ptb ptaa 5)<br />             nil<br />             (setq lis (list pta ptaa))<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (setq        lis (vl-sort lis<br />                      (function (lambda (e1 e2)<br />                                  (< (car e1) (car e2))<br />                                )<br />                      )<br />             )<br />   )<br />   (command "select" ss "")<br />   (setq ss-CIRCLE (ssget "p" '((0 . "CIRCLE"))))<br />   (setq ii 0)<br />   (repeat (sslength ss-CIRCLE)<br />     (setq name (ssname ss-CIRCLE ii)<br />           ii   (1+ ii)<br />           cen  (cdr (assoc 40 (entget name)))<br />     )<br />     (setq app (append (list (append (list cen) (list name))) app))<br />   )<br />   (setq        app (vl-sort app<br />                      (function (lambda (e1 e2)<br />                                  (< (car e1) (car e2))<br />                                )<br />                      )<br />             )<br />   )<br />   (mapcar '(lambda (x y)<br />              (vl-cmdf "move"<br />                       (sss (cadr y))<br />                       ""<br />                       (cdr (assoc 10 (entget (cadr y))))<br />                       x<br />              )<br />            )<br />           lis<br />           app<br />   )<br /> )<br /> (defun sss (na / cen en pt- pt+ pt< pt> rad ss)<br />   (setq en (entget na))<br />   (setq rad (cdr (assoc 40 en)))<br />   (setq cen (cdr (assoc 10 en)))<br />   (setq pt> (polar cen 0 (1+ rad)))<br />   (setq pt< (polar cen pi (1+ rad)))<br />   (setq pt+ (polar cen (* 0.5 pi) (1+ rad)))<br />   (setq pt- (polar cen (* 1.5 pi) (1+ rad)))<br />   (setq ss (ssget "cp" (list pt> pt+ pt< pt-)))<br /> )

waa21301

哦，谢谢楼上各位，谢谢434939575兄帮忙。

waa21301

分别为圆和数字，线是L线，谢谢cdma2546兄。

yp9819

测试了上面老师的程序，加载后，输入命令，不能运行。