源码无聊贴:xj(连接首尾相连线条成封闭多义线) --by 狂刀 2007.9

狂刀lxx

请留意演示，有多分支选择gong neng
以下是源码，纯无聊抛砖引玉，有要修改完善者勿扰

2. 
   
3. ;| xj(连接首尾相连线条成封闭多义线) --by 狂刀 2007.9
   
4. 说明: 方式:单点一条,自动搜索，多分支提示.
   
5. |;
   
6. (defun c:xj (/ E ESS FIL OS P1 PA PX0 PX1 ROOP SS SS2 SSS SSS2 X ee)
   
7.   (princ "\n 连接首尾相连线条成封闭多义线------by 狂刀 2007.9")
   
8.   (command ".undo" "be")
   
9.   (setq fil '((0 . "LINE,ARC,*POLYLINE"))
   
10. os (getvar "osmode")
    
11. pa (getvar "PEDITACCEPT")
    
12. ssend(ssadd))
    
13.   (setvar "osmode" 0)
    
14.   (setvar "PEDITACCEPT" 1)
    
15.   ;; 生成首尾相连选集.
    
16.   (while (and (princ "\n 选形成多义线的其中一条边线 <退出>:")
    
17.        (setq ss (ssget ":S" fil))
    
18.   )
    
19.     (setq sss (ssadd)
    
20.    sss2(ssadd)
    
21.    roop nil)
    
22.     (setq e (ssname ss 0)
    
23.    e0 e
    
24.    p0 (vlax-curve-getstartpoint e)
    
25.    p1(vlax-curve-getendpoint e))
    
26.     (vlax-put (vlax-ename->vla-object e) 'color 1)
    
27.     (ssadd e sss)
    
28.     (subxj ee p0)
    
29.     (subxj ee p1)
    
30.     (command ".pedit" "m" sss "" "j" 0.01  "")
    
31.     (setq ee (entlast))
    
32.     (redraw ee 3)
    
33.     ;(vlax-put (vlax-ename->vla-object ee) 'color 3)
    
34.     (ssadd ee ssend)
    
35.   )
    
36.   (mapcar '(lambda(x)(redraw x 4))(xss2lst ssend))
    
37.   (setvar "PEDITACCEPT" pa)
    
38.   (setvar "osmode" os)
    
39.   (command ".undo" "e")
    
40.   (princ)
    
41. )
    
42. ;;
    
43. (defun subxj (EE p1 / PX0 PX1 ROOP X esss ess)
    
44.   (setq e ee)
    
45.   (while (and (setq ss2 (ssget "c" p1 p1 fil))
    
46.   (not rooP)
    
47.     )
    
48.       (setq ess (xss2lst ss2)
    
49.      esss(xss2lst sss))
    
50.       (mapcar'(lambda(x)(setq ess(vl-remove x ess))) esss)
    
51.       (if (not (member e0 ess))
    
52. (if (and ess (< 1 (length ess)))
    
53.    (progn (mapcar '(lambda (x) (redraw x 3)) ess)
    
54.    (setq e (car (entsel "\n 选择分支:")))
    
55.    (mapcar '(lambda (x) (redraw x 4)) ess)
    
56.    )
    
57.    (setq e (car ess))
    
58. )
    
59.       )
    
60.       (if (and e (not (ssmemb e sss)))
    
61. (progn
    
62.    (ssadd e sss)
    
63.    (vlax-put (vlax-ename->vla-object e) 'color 1)
    
64.    (setq px0 (vlax-curve-getstartpoint e)
    
65.   px1 (vlax-curve-getendpoint e)
    
66.    )
    
67.    (if (equal p1 px0 1e-4)
    
68.      (setq p1 px1)
    
69.      (setq p1 px0)
    
70.    )
    
71. )
    
72. (setq roop T)
    
73.       )
    
74.     )
    
75. )
    
76. ;; 配套函数, 提取选集实体名列表.
    
77. (defun xss2lst (ss / i e lst)
    
78.   (setq i -1)
    
79.   (while (setq e (ssname ss (setq i (1+ i))))
    
80.     (setq lst (cons e lst))
    
81.   )
    
82.   (reverse lst)
    
83. )
    

<br /> ;| xj(连接首尾相连线条成封闭多义线) --by 狂刀 2007.9<br /> 说明: 方式:单点一条,自动搜索，多分支提示.<br /> |;<br /> (defun c:xj (/ E ESS FIL OS P1 PA PX0 PX1 ROOP SS SS2 SSS SSS2 X ee)<br />   (princ "\n 连接首尾相连线条成封闭多义线------by 狂刀 2007.9")<br />   (command ".undo" "be")<br />   (setq fil '((0 . "LINE,ARC,*POLYLINE"))<br /> os (getvar "osmode")<br /> pa (getvar "PEDITACCEPT")<br /> ssend(ssadd))<br />   (setvar "osmode" 0)<br />   (setvar "PEDITACCEPT" 1)<br />   ;; 生成首尾相连选集.<br />   (while (and (princ "\n 选形成多义线的其中一条边线 <退出>:")<br />        (setq ss (ssget ":S" fil))<br />   )<br />     (setq sss (ssadd)<br />    sss2(ssadd)<br />    roop nil)<br />     (setq e (ssname ss 0)<br />    e0 e<br />    p0 (vlax-curve-getstartpoint e)<br />    p1(vlax-curve-getendpoint e))<br />     (vlax-put (vlax-ename->vla-object e) 'color 1)<br />     (ssadd e sss)<br />     (subxj ee p0)<br />     (subxj ee p1)<br />     (command ".pedit" "m" sss "" "j" 0.01  "")<br />     (setq ee (entlast))<br />     (redraw ee 3)<br />     ;(vlax-put (vlax-ename->vla-object ee) 'color 3)<br />     (ssadd ee ssend)<br />   )<br />   (mapcar '(lambda(x)(redraw x 4))(xss2lst ssend))<br />   (setvar "PEDITACCEPT" pa)<br />   (setvar "osmode" os)<br />   (command ".undo" "e")<br />   (princ)<br /> )<br /> ;;<br /> (defun subxj (EE p1 / PX0 PX1 ROOP X esss ess)<br />   (setq e ee)<br />   (while (and (setq ss2 (ssget "c" p1 p1 fil))<br />   (not rooP)<br />     )<br />       (setq ess (xss2lst ss2)<br />      esss(xss2lst sss))<br />       (mapcar'(lambda(x)(setq ess(vl-remove x ess))) esss)<br />       (if (not (member e0 ess))<br /> (if (and ess (< 1 (length ess)))<br />    (progn (mapcar '(lambda (x) (redraw x 3)) ess)<br />    (setq e (car (entsel "\n 选择分支:")))<br />    (mapcar '(lambda (x) (redraw x 4)) ess)<br />    )<br />    (setq e (car ess))<br /> )<br />       )<br />       (if (and e (not (ssmemb e sss)))<br /> (progn<br />    (ssadd e sss)<br />    (vlax-put (vlax-ename->vla-object e) 'color 1)<br />    (setq px0 (vlax-curve-getstartpoint e)<br />   px1 (vlax-curve-getendpoint e)<br />    )<br />    (if (equal p1 px0 1e-4)<br />      (setq p1 px1)<br />      (setq p1 px0)<br />    )<br /> )<br /> (setq roop T)<br />       )<br />     )<br /> )<br /> ;; 配套函数, 提取选集实体名列表.<br /> (defun xss2lst (ss / i e lst)<br />   (setq i -1)<br />   (while (setq e (ssname ss (setq i (1+ i))))<br />     (setq lst (cons e lst))<br />   )<br />   (reverse lst)<br /> )<br />

zhangrunze

1006882982 发表于 2012-6-26 03:27
(defun c:pp()
    (setq cm (getvar "cmdecho"))
    (setvar "cmdecho" 0)

感谢分享~
单线或多线转多段线~

白色微風1991

這個功能效率很高，謝謝樓主分享    謝謝分享

SYTDD

狂刀无聊出品都这么帮，希望你天天都无聊，呵呵，谢谢分享

461045462

谢谢楼主的分享
收藏了,下来学习领会
谢谢

display18

收藏备用，呵呵

kinglzk2000

no function definition: VLAX-CURVE-GETSTARTPOINT

13579

收藏备用

e688w

备用！正在收集这方面的资料做水力计算！

killer9806

谢谢分享。程序利用点的方式获取物体进行组建多义线。

669423907

狂刀的程序，一定要收藏！

luyu9635

希望你天天都无聊，呵呵

yhkk0317

正缺这功能呢