[弹指神通]：消除复线上多余顶点的程序(不是重复顶点)

它山之石

图

njshf

用对接命令？

eachy

2. 
   
3. ;;适用 AutoCAD 2006 下的 Pline 去除重复点及"瘦身"程序
   
4. ;;利用 Join 命令和 Pedit 组合达到去除重复点及合并线段
   
5. ;;对伪闭合线可以处理
   
6. ;;注意: 对含宽度的Pline、拟合的Pline处理后会变形
   
7. (defun xdl-Clearcset (/ cset)
   
8.   (if (not (vl-catch-all-error-p
   
9.              (setq cset
   
10.                     (vl-catch-all-apply
    
11.                       'vla-item
    
12.                       (list
    
13.                         (vla-get-selectionsets
    
14.                           (vla-get-activedocument (vlax-get-acad-object)) ;_
    
15.                         )
    
16.                         "CURRENT"
    
17.                       )
    
18.                     )
    
19.              )
    
20.            )
    
21.       )
    
22.     (vla-delete cset)
    
23.   )
    
24.   (princ)
    
25. )
    
26. (defun c:clwpl (/ ss obj el el1 el2 a l)
    
27.   (xdl-clearcset)
    
28.   (if (setq ss (ssget '((0 . "lwpolyline"))))
    
29.     (progn
    
30.       (setvar "cmdecho" 0)
    
31.       (setvar "peditaccept" 1)
    
32.       (command ".undo" "be")
    
33.       (vlax-for        obj (vla-get-activeselectionset
    
34.                       (vla-get-activedocument (vlax-get-acad-object))
    
35.                     )
    
36.         (setq el  (mapcar 'vlax-vla-object->ename
    
37.                           (safearray-value (variant-value (vla-explode obj)))
    
38.                   )
    
39.               el1 el
    
40.               l          (length el)
    
41.         )
    
42.         (repeat        l
    
43.           (setq        a   (car el1)
    
44.                 el2 (vl-remove-if
    
45.                       '(lambda (x) (vlax-erased-p x))
    
46.                       (cdr el1)
    
47.                     )
    
48.                 el1 (cdr el1)
    
49.           )
    
50.           (if (and el2
    
51.                    (not (vlax-erased-p a))
    
52.               )
    
53.             (progn
    
54.               (command ".join" a)
    
55.               (mapcar 'command el2)
    
56.               (command "")
    
57.             )
    
58.           )
    
59.         )
    
60.         (command ".pedit" "m")
    
61.         (mapcar        'command
    
62.                 (vl-remove-if
    
63.                   '(lambda (x) (vlax-erased-p x))
    
64.                   el
    
65.                 )
    
66.         )
    
67.         (command "")
    
68.         (command "j")
    
69.         (command "0")
    
70.         (command "")
    
71.       )
    
72.       (setvar "peditaccept" 0)
    
73.       (command ".erase" ss "")
    
74.       (command ".undo" "end")
    
75.     )
    
76.   )
    
77.   (princ)
    
78. )

<br /> ;;适用 AutoCAD 2006 下的 Pline 去除重复点及"瘦身"程序<br /> ;;利用 Join 命令和 Pedit 组合达到去除重复点及合并线段<br /> ;;对伪闭合线可以处理<br /> ;;注意: 对含宽度的Pline、拟合的Pline处理后会变形<br /> (defun xdl-Clearcset (/ cset)<br />   (if (not (vl-catch-all-error-p<br />              (setq cset<br />                     (vl-catch-all-apply<br />                       'vla-item<br />                       (list<br />                         (vla-get-selectionsets<br />                           (vla-get-activedocument (vlax-get-acad-object)) ;_<br />                         )<br />                         "CURRENT"<br />                       )<br />                     )<br />              )<br />            )<br />       )<br />     (vla-delete cset)<br />   )<br />   (princ)<br /> )<br /> (defun c:clwpl (/ ss obj el el1 el2 a l)<br />   (xdl-clearcset)<br />   (if (setq ss (ssget '((0 . "lwpolyline"))))<br />     (progn<br />       (setvar "cmdecho" 0)<br />       (setvar "peditaccept" 1)<br />       (command ".undo" "be")<br />       (vlax-for        obj (vla-get-activeselectionset<br />                       (vla-get-activedocument (vlax-get-acad-object))<br />                     )<br />         (setq el  (mapcar 'vlax-vla-object->ename<br />                           (safearray-value (variant-value (vla-explode obj)))<br />                   )<br />               el1 el<br />               l          (length el)<br />         )<br />         (repeat        l<br />           (setq        a   (car el1)<br />                 el2 (vl-remove-if<br />                       '(lambda (x) (vlax-erased-p x))<br />                       (cdr el1)<br />                     )<br />                 el1 (cdr el1)<br />           )<br />           (if (and el2<br />                    (not (vlax-erased-p a))<br />               )<br />             (progn<br />               (command ".join" a)<br />               (mapcar 'command el2)<br />               (command "")<br />             )<br />           )<br />         )<br />         (command ".pedit" "m")<br />         (mapcar        'command<br />                 (vl-remove-if<br />                   '(lambda (x) (vlax-erased-p x))<br />                   el<br />                 )<br />         )<br />         (command "")<br />         (command "j")<br />         (command "0")<br />         (command "")<br />       )<br />       (setvar "peditaccept" 0)<br />       (command ".erase" ss "")<br />       (command ".undo" "end")<br />     )<br />   )<br />   (princ)<br /> )

flowerson

eachy的程序 我在T字形的pl线上测试错误了。