排水管线

baoxiaozhong

如何修改下列的代碼? 可以做到將互垂或是相交的管線變成如下圖的排水管線，最重要的是要能指定排水方向。

2. 
   
3. (defun c:arcit ( / *error* _inters arc objs pts rad dir ang)
   
4. (vl-load-com)
   
5. (defun *error* (msg)
   
6. (command "._undo" "_end")
   
7. (setvar 'osmode old_os) (setvar 'cmdecho cmd1)
   
8. )
   
9. 
   
10. (defun _Inters (ss / en pts ss en pts)
    
11. (repeat (sslength ss)
    
12. (setq en (cons (vlax-ename->vla-object (ssname ss 0)) en))
    
13. (ssdel (ssname ss 0) ss)
    
14. )
    
15. (while en
    
16. (setq pt (car en))
    
17. (mapcar '(lambda (p l / l pt_)
    
18. (while l (if (setq v (vlax-invoke p
    
19. 'IntersectWith (car l)
    
20. acExtendNone ))
    
21. (repeat (/ (length v) 3)
    
22. (setq pt_ (list (car v) (cadr v) (caddr v))
    
23. v (member (nth 3 v) v)
    
24. )
    
25. (if (and pt_ (not (vl-position pt_ pts)))
    
26. (setq pts (cons pt_ pts)))))
    
27. (setq l (cdr l))))
    
28. (list pT)
    
29. (list (setq en (vl-remove pt en)))
    
30. )
    
31. ) pts
    
32. )
    
33. (defun Arc (cen rad sAng eAng)
    
34. (entmakex (list (cons 0 "ARC") (cons 10 cen)
    
35. (cons 40 rad) (cons 50 sAng)
    
36. (cons 51 eAng))))
    
37. (setq old_os (getvar 'osmode)
    
38. plw (getvar 'plinewid)
    
39. cmd1 (getvar 'cmdecho)
    
40. clyer (getvar 'clayer))
    
41. 
    
42. (setvar 'osmode 0)
    
43. (setvar 'cmdecho 0)
    
44. (command "._undo" "_begin")
    
45. 
    
46. (setq objs (ssget ":L" '((0 . "*LINE"))))
    
47. (setq pts (_inters objs))
    
48. (setq rad (if (not rad) 1.0 rad))
    
49. (setq rad (cond
    
50. ((getdist (strcat "\nEnter distance"
    
51. (if rad (strcat " <" (rtos rad) ">: ") ": ")
    
52. )))(rad)))
    
53. (initget 1 "H V")
    
54. (setq dir (getkword "\nEnter Option:/ Horizontal/Vertical]: "))
    
55. (setq ang (if (eq dir "H")
    
56. '(0 pi)
    
57. '((/ pi 2.0) (* pi 1.5))
    
58. )
    
59. )
    
60. (foreach p pts
    
61. (command "_break"
    
62. (polar p (setq fa (eval (car ang))) rad)
    
63. (polar p (setq ea (eval (cadr ang))) rad)
    
64. )
    
65. (setq carc (arc p rad fa ea))
    
66. )
    
67. (*error* "")
    
68. (princ)
    
69. )

<br /> (defun c:arcit ( / *error* _inters arc objs pts rad dir ang)<br /> (vl-load-com)<br /> (defun *error* (msg)<br /> (command "._undo" "_end")<br /> (setvar 'osmode old_os) (setvar 'cmdecho cmd1)<br /> )<br /> <br /> (defun _Inters (ss / en pts ss en pts)<br /> (repeat (sslength ss)<br /> (setq en (cons (vlax-ename->vla-object (ssname ss 0)) en))<br /> (ssdel (ssname ss 0) ss)<br /> )<br /> (while en<br /> (setq pt (car en))<br /> (mapcar '(lambda (p l / l pt_)<br /> (while l (if (setq v (vlax-invoke p<br /> 'IntersectWith (car l)<br /> acExtendNone ))<br /> (repeat (/ (length v) 3)<br /> (setq pt_ (list (car v) (cadr v) (caddr v))<br /> v (member (nth 3 v) v)<br /> )<br /> (if (and pt_ (not (vl-position pt_ pts)))<br /> (setq pts (cons pt_ pts)))))<br /> (setq l (cdr l))))<br /> (list pT)<br /> (list (setq en (vl-remove pt en)))<br /> )<br /> ) pts<br /> )<br /> (defun Arc (cen rad sAng eAng)<br /> (entmakex (list (cons 0 "ARC") (cons 10 cen)<br /> (cons 40 rad) (cons 50 sAng)<br /> (cons 51 eAng))))<br /> (setq old_os (getvar 'osmode)<br /> plw (getvar 'plinewid)<br /> cmd1 (getvar 'cmdecho)<br /> clyer (getvar 'clayer))<br /> <br /> (setvar 'osmode 0)<br /> (setvar 'cmdecho 0)<br /> (command "._undo" "_begin")<br /> <br /> (setq objs (ssget ":L" '((0 . "*LINE"))))<br /> (setq pts (_inters objs))<br /> (setq rad (if (not rad) 1.0 rad))<br /> (setq rad (cond<br /> ((getdist (strcat "\nEnter distance"<br /> (if rad (strcat " <" (rtos rad) ">: ") ": ")<br /> )))(rad)))<br /> (initget 1 "H V")<br /> (setq dir (getkword "\nEnter Option:/ Horizontal/Vertical]: "))<br /> (setq ang (if (eq dir "H")<br /> '(0 pi)<br /> '((/ pi 2.0) (* pi 1.5))<br /> )<br /> )<br /> (foreach p pts<br /> (command "_break"<br /> (polar p (setq fa (eval (car ang))) rad)<br /> (polar p (setq ea (eval (cadr ang))) rad)<br /> )<br /> (setq carc (arc p rad fa ea))<br /> )<br /> (*error* "")<br /> (princ)<br /> )