求大神帮写一个调整leader角度的程序，万分感激！

fire9527

想要实现的功能如截图和上传的测试图中所述，
个人感觉“初步诉求”就够用了，后面两个只是更完善罢了，如果很难可以忽略，
这帖子立了很长时间了，先后得到 ZZXXQQ、xyp1964、vectra三位大神的热情相助（衷心感谢你们！），演示效果很好，但是很遗憾，本人编程小白，在自己电脑上用就是不行
ZZXXQQ帮在下写的程序，CAD提示：; 错误: 参数太少
xyp1964帮在下写的程序，只是向右平移的效果，没有院长本人演示的效果
vectra的提示在下照做了，还是没有效果

这个问题也许在你们看来已经解决了，但是在下实在是捣鼓不明白，为体现诚意，特意提高悬赏，还希望你们好人做到底，送佛送到西，让小弟把这件宝贝带到工作中，再次叩谢！

danxingpen

1. 
   

复制代码

2. (defun c:tt ()
   
3. (if (setq ss (ssget '((0 . "LEADER"))))
   
4.   (repeat (setq i (sslength ss))
   
5.    (setq ent (entget(ssname ss (setq i (1- i)))))
   
6.    (setq ptx (cadr(assoc 10 ent)))
   
7.    (setq  a 0
   
8.     n(length ent)
   
9.     )
   
10.     (foreach x ent
    
11.       (if (= (car x) 10)
    
12.   (progn
    
13.     (setq a(1+ a))
    
14.     (if (= a 2)
    
15.       (setq movex (- ptx (cadr x)))
    
16.     )
    
17.   )  
    
18.       )
    
19.     )
    
20.    (setq mtext(cdr(assoc '340 ent)))
    
21.    (setq mtext(entget mtext))
    
22.    (setq mtext(subst (cons 10 (mapcar '+ (cdr (assoc '10 mtext))(list movex 0 0)))
    
23.           (assoc '10 mtext)
    
24.           mtext
    
25.           ))
    
26.     (entmod mtext)
    
27.   )
    
28. )
    
29. (princ)
    
30. )

(defun c:tt ()<br /> (if (setq ss (ssget '((0 . "LEADER"))))<br />   (repeat (setq i (sslength ss))<br />    (setq ent (entget(ssname ss (setq i (1- i)))))<br />    (setq ptx (cadr(assoc 10 ent)))<br />    (setq  a 0<br />     n(length ent)<br />     )<br />     (foreach x ent<br />       (if (= (car x) 10)<br />   (progn<br />     (setq a(1+ a))<br />     (if (= a 2)<br />       (setq movex (- ptx (cadr x)))<br />     )<br />   )  <br />       )<br />     )<br />    (setq mtext(cdr(assoc '340 ent)))<br />    (setq mtext(entget mtext))<br />    (setq mtext(subst (cons 10 (mapcar '+ (cdr (assoc '10 mtext))(list movex 0 0)))<br />           (assoc '10 mtext)<br />           mtext<br />           ))<br />     (entmod mtext)<br />   )<br /> )<br /> (princ)<br /> )

;在ZZXXQQ的基础上改了一下,你这个引线带编组的,主驱动是mtext,,,所以,,,,他们的都移动不了

fire9527

自己默默的顶起来

ZZXXQQ

2. ;引线规整 明经 ZZXXQQ 2015.4.6 2015.5.31
   
3. (defun c:tt ()
   
4. (if (setq ss (ssget '((0 . "LEADER"))))
   
5.   (repeat (setq i (sslength ss))
   
6.    (setq ent (entget(ssname ss (setq i (1- i)))))
   
7.    (setq ptx (cadr(assoc 10 ent)))
   
8.    (setq ent1 (list) a T)
   
9.    (foreach x ent
   
10.     (if (/= (car x) 10)
    
11.      (setq ent1 (cons x ent1))
    
12.      (if (equal (cadr x) ptx 1e-6)
    
13.       (setq ent1 (cons x ent1))
    
14.       (if a (setq ent1 (cons (list (car x) ptx (caddr x) (last x)) ent1) a nil)
    
15.        (setq ent1 (cons x ent1))
    
16.       )
    
17.      )
    
18.     )
    
19.    )
    
20.    (entmod (reverse ent1))
    
21.   )
    
22. )
    
23. (princ)
    
24. )
    

;引线规整 明经 ZZXXQQ 2015.4.6 2015.5.31<br /> (defun c:tt ()<br /> (if (setq ss (ssget '((0 . "LEADER"))))<br />   (repeat (setq i (sslength ss))<br />    (setq ent (entget(ssname ss (setq i (1- i)))))<br />    (setq ptx (cadr(assoc 10 ent)))<br />    (setq ent1 (list) a T)<br />    (foreach x ent<br />     (if (/= (car x) 10)<br />      (setq ent1 (cons x ent1))<br />      (if (equal (cadr x) ptx 1e-6)<br />       (setq ent1 (cons x ent1))<br />       (if a (setq ent1 (cons (list (car x) ptx (caddr x) (last x)) ent1) a nil)<br />        (setq ent1 (cons x ent1))<br />       )<br />      )<br />     )<br />    )<br />    (entmod (reverse ent1))<br />   )<br /> )<br /> (princ)<br /> )<br />

xyp1964

2. ;; xyp-LeaderR 引线实体归正 (xyp-LeaderR 引线实体)
   
3. (defun xyp-LeaderR (s1 / ptn lst s2 p1 p2 p3)
   
4.   (setq ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s1))
   
5.         ptn (mapcar 'cdr ptn)
   
6.         lst (vl-remove-if-not '(lambda (x) (= (car x) 330)) (entget s1))
   
7.         lst (mapcar 'cdr lst)
   
8.         s2  (car lst)
   
9.         lst (vl-remove-if-not '(lambda (x) (= (car x) 340)) (entget s2))
   
10.         s2  (last (mapcar 'cdr lst))
    
11.         p1  (car ptn)
    
12.         p2  (cadr ptn)
    
13.         p3  (inters p1 (polar p1 (* pi 0.5) 10) p2 (polar p2 0 10) nil)
    
14.   )
    
15.   (command "move" s2 "" "non" p2 "non" p3)
    
16. )
    
17. 
    
18. ;; tt(引线归正)
    
19. (defun c:tt ()
    
20.   (setq i -1)
    
21.   (if (setq ss (ssget '((0 . "leader"))))
    
22.     (while (setq s1 (ssname ss (setq i (1+ i))))
    
23.       (xyp-LeaderR s1)
    
24.     )
    
25.   )
    
26.   (princ)
    
27. )
    

;; xyp-LeaderR 引线实体归正 (xyp-LeaderR 引线实体)<br /> (defun xyp-LeaderR (s1 / ptn lst s2 p1 p2 p3)<br />   (setq ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s1))<br />         ptn (mapcar 'cdr ptn)<br />         lst (vl-remove-if-not '(lambda (x) (= (car x) 330)) (entget s1))<br />         lst (mapcar 'cdr lst)<br />         s2  (car lst)<br />         lst (vl-remove-if-not '(lambda (x) (= (car x) 340)) (entget s2))<br />         s2  (last (mapcar 'cdr lst))<br />         p1  (car ptn)<br />         p2  (cadr ptn)<br />         p3  (inters p1 (polar p1 (* pi 0.5) 10) p2 (polar p2 0 10) nil)<br />   )<br />   (command "move" s2 "" "non" p2 "non" p3)<br /> )<br /> <br /> ;; tt(引线归正)<br /> (defun c:tt ()<br />   (setq i -1)<br />   (if (setq ss (ssget '((0 . "leader"))))<br />     (while (setq s1 (ssname ss (setq i (1+ i))))<br />       (xyp-LeaderR s1)<br />     )<br />   )<br />   (princ)<br /> )<br />

xyp1964

fire9527

ZZXXQQ 发表于 2015-4-6 10:40

龙版主，您的程序有这个提示：
选择对象:
; 错误: 参数太少

fire9527

xyp1964 发表于 2015-4-6 13:58

院长，怎么实现不了您演示的效果了？我试了，只是向右平移而已，您的工具箱也是加载了的

vectra

把院长的xyp-LeaderR函数修改为下面的代码就可以了

1. (defun xyp-LeaderR (s1 / ptn lst s2 p1 p2 p3)
   
2.   (setq        ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s1))
   
3.         ptn (mapcar 'cdr ptn)
   
4.         lst (vl-remove-if-not '(lambda (x) (= (car x) 340)) (entget s1))
   
5.         lst (mapcar 'cdr lst)
   
6.         s2  (car lst)
   
7.         p1  (car ptn)
   
8.         p2  (cadr ptn)
   
9.         p3  (list (car p1) (cadr p2) 0)
   
10.   )
    
11.   (command "move" s2 "" "non" p2 "non" p3)
    
12. )

(defun xyp-LeaderR (s1 / ptn lst s2 p1 p2 p3)<br />   (setq        ptn (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget s1))<br />         ptn (mapcar 'cdr ptn)<br />         lst (vl-remove-if-not '(lambda (x) (= (car x) 340)) (entget s1))<br />         lst (mapcar 'cdr lst)<br />         s2  (car lst)<br />         p1  (car ptn)<br />         p2  (cadr ptn)<br />         p3  (list (car p1) (cadr p2) 0)<br />   )<br />   (command "move" s2 "" "non" p2 "non" p3)<br /> )

fire9527

xyp1964 发表于 2015-4-6 15:16

院长，怎么只是移动呢？很需要这个功能，万望回复