求一个LISP程序，现在小弟只有1个明经币，给不了多少悬赏，希望有好心的老师帮忙写段

员工C接板QQ

希望有段程序可以自动完成，如图1转成图2的程序，    首先：选择要将双线转为单线的对象     然后：输入两条线之间的模糊间距，执行完以后将封闭的对象（如图1） 转成单线（如图2），如有哪位好心的老师，希望可以帮小弟编写一个程序的源码，本人感激不尽！

Andyhon

Try ...

2. 
   
3. (defun Line2-1 (sset)
   
4.    (setq pts (acet-geom-ss-extents sset nil)    ; ET needed
   
5.          xx1 (caar pts)
   
6.          xx2 (caadr pts)
   
7.          yy5 (/ (+ (cadar pts) (cadadr pts)) 2)
   
8.          pt1 (list xx1 yy5)
   
9.          pt2 (list xx2 yy5)
   
10.     )
    
11.     (command "erase" sset "")
    
12.     (entmake (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2)))
    
13. )
    
14. 
    
15. (defun AC2-1 (sset)
    
16.    (setq ee1 (ssname sset 0)
    
17.          ee2 (ssname sset 1)
    
18.          rr1 (cdr (assoc 40 (entget ee1)))
    
19.          dat (entget ee2)
    
20.          rrr (assoc 40 dat)
    
21.          rr2 (/ (+ rr1 (cdr rrr)) 2)
    
22.     )
    
23.     (entmod (subst (cons 40 rr2) rrr dat))
    
24.     (command "erase" ss "r"ee2 "")
    
25. )
    
26. 
    
27. (defun C:test ()
    
28.    (setq ss (ssget '((0 . "Arc,Circle,Line")))
    
29.          nn (sslength ss)
    
30.    )
    
31.    
    
32.    (cond
    
33.     ((> nn 2)   
    
34.      (cond
    
35.       ((setq ssa (ssget "P" '((0 . "Arc"))))
    
36.        (AC2-1 ssa)
    
37.       )
    
38.       ((= nn 4)   ; Lines
    
39.        (Line2-1 ss)   
    
40.     )))
    
41.     (T            ; Circle
    
42.      (AC2-1 ss)
    
43.    ))
    
44. )
    

<br /> (defun Line2-1 (sset)<br />    (setq pts (acet-geom-ss-extents sset nil)    ; ET needed<br />          xx1 (caar pts)<br />          xx2 (caadr pts)<br />          yy5 (/ (+ (cadar pts) (cadadr pts)) 2)<br />          pt1 (list xx1 yy5)<br />          pt2 (list xx2 yy5)<br />     )<br />     (command "erase" sset "")<br />     (entmake (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2)))<br /> )<br /> <br /> (defun AC2-1 (sset)<br />    (setq ee1 (ssname sset 0)<br />          ee2 (ssname sset 1)<br />          rr1 (cdr (assoc 40 (entget ee1)))<br />          dat (entget ee2)<br />          rrr (assoc 40 dat)<br />          rr2 (/ (+ rr1 (cdr rrr)) 2)<br />     )<br />     (entmod (subst (cons 40 rr2) rrr dat))<br />     (command "erase" ss "r"ee2 "")<br /> )<br /> <br /> (defun C:test ()<br />    (setq ss (ssget '((0 . "Arc,Circle,Line")))<br />          nn (sslength ss)<br />    )<br />    <br />    (cond<br />     ((> nn 2)    <br />      (cond<br />       ((setq ssa (ssget "P" '((0 . "Arc"))))<br />        (AC2-1 ssa) <br />       )<br />       ((= nn 4)   ; Lines<br />        (Line2-1 ss)    <br />     )))<br />     (T            ; Circle<br />      (AC2-1 ss)<br />    )) <br /> )<br />

cable2004

最好上个cad图给别人测试！

员工C接板QQ

老师 测试图已经上传

员工C接板QQ

Andyhon 发表于 2013-1-14 20:21
Try ...

谢谢，Andyhon老师，这个程序正是我想要的

员工C接板QQ

Andyhon 发表于 2013-1-14 14:36
Try ...

老师，这个用了哪个版本的通用函数，我想修改下，可以窗选好多对象，把其都变成单线，如果老师有空，是否可以帮我改下

Andyhon

Acet-* 函数  ; ET needed
Express Tools 详站内老帖