选择图中的若干物体，则凡与这些物体相接触或相交的其它物体被自动改到“图层1”。

yunfengning

申请一个lsp程序：选择图中的若干物体，则凡与这些物体相接触或相交(即粘连)的其它物体被自动改到“图层1”。

补充上传测试的DWG文件，期待高手出手。

llsheng_73

针对你所给的图形测试没问题，但对于一些其它内容，比如图块等下边的代码肯定行不通

1. (defun SStoES(s / m n e)
   
2.   (if s(progn
   
3.    (setq n(sslength s)m 0)
   
4.    (while(< m n)
   
5.      (setq e(if e(append e(list(ssname s m)))(list(ssname s m)))m(1+ m))))
   
6.     )e)
   
7. 
   
8. (defun C:tt(/ s1 s e f)
   
9.   (VL-LOAD-COM)
   
10.   (setq la"临时图层1")
    
11.   (setq s1(ssget'((0 . "LINE,LWPOLYLINE,POLYLINE,SPLINE,CIRCLE")(62 . 4))))
    
12.   (if s1(progn
    
13.     (setq s1(SStoES s1)
    
14.     s(SStoES(ssget"X"(list(cons -4 "<NOT")(cons 8 la)(cons -4 "NOT>")))))
    
15.     (foreach e s1(if(member e s)(setq s(vl-remove e s))))
    
16.     (foreach e s1
    
17.       (foreach f s
    
18.         (if(vlax-invoke(vlax-ename->vla-object e)'IntersectWith(vlax-ename->vla-object f)0)
    
19.     (vlax-put-property(vlax-ename->vla-object f)'Layer la))
    
20.         )
    
21.       )
    
22.     )
    
23.     )
    
24.   )

(defun SStoES(s / m n e)<br />   (if s(progn<br />    (setq n(sslength s)m 0)<br />    (while(< m n)<br />      (setq e(if e(append e(list(ssname s m)))(list(ssname s m)))m(1+ m))))<br />     )e)<br /> <br /> (defun C:tt(/ s1 s e f)<br />   (VL-LOAD-COM)<br />   (setq la"临时图层1")<br />   (setq s1(ssget'((0 . "LINE,LWPOLYLINE,POLYLINE,SPLINE,CIRCLE")(62 . 4))))<br />   (if s1(progn<br />     (setq s1(SStoES s1)<br />     s(SStoES(ssget"X"(list(cons -4 "<NOT")(cons 8 la)(cons -4 "NOT>")))))<br />     (foreach e s1(if(member e s)(setq s(vl-remove e s))))<br />     (foreach e s1<br />       (foreach f s<br />         (if(vlax-invoke(vlax-ename->vla-object e)'IntersectWith(vlax-ename->vla-object f)0)<br />     (vlax-put-property(vlax-ename->vla-object f)'Layer la))<br />         )<br />       )<br />     )<br />     )<br />   )

Andyhon

这些物体 ? 那些?
相接触或相交?  公差容忍度?

上述 得有验证的样本文件 为依据,请上传 (*.Dwg)

wau2000022

联系我QQ496968041

Andyhon

;;; 请依实务修订补强

2. 
   
3. (defun C:try ()
   
4.    (setq ss (ssget '((0 . "Lwpolyline,Circle")))
   
5.           i  -1
   
6.    )
   
7.    (while (setq ee (ssname ss (setq i (1+ i))))
   
8.      (setq dat (entget ee))
   
9.      (cond
   
10.       ((= (dxf 0 dat) "CIRCLE")
    
11.        (setq po (dxf 10 dat)
    
12.              rr (dxf 40 dat)
    
13.              vv 0.0
    
14.              aa (/ Pi 64)             ; maybe something
    
15.             pts nil
    
16.        )      
    
17.        (repeat 128          ; 360
    
18.          (setq pts (cons (polar po (setq vv (+ vv aa)) rr) pts))
    
19.       ))
    
20.       (T          ; LwPolyLine
    
21.        (setq pts (acet-geom-pline-point-list ee nil))
    
22.      ))
    
23.      (setq ss2 (ssget "CP" pts))
    
24.      (ssdel ee ss2)
    
25.      (command "Chprop" ss2 "" "La" "1" "c" "ByLayer" "")
    
26.     )
    
27. )
    

<br /> (defun C:try ()<br />    (setq ss (ssget '((0 . "Lwpolyline,Circle")))<br />           i  -1 <br />    )<br />    (while (setq ee (ssname ss (setq i (1+ i))))<br />      (setq dat (entget ee))<br />      (cond <br />       ((= (dxf 0 dat) "CIRCLE")<br />        (setq po (dxf 10 dat)<br />              rr (dxf 40 dat)<br />              vv 0.0<br />              aa (/ Pi 64)             ; maybe something<br />             pts nil <br />        )      <br />        (repeat 128          ; 360<br />          (setq pts (cons (polar po (setq vv (+ vv aa)) rr) pts))<br />       ))<br />       (T          ; LwPolyLine<br />        (setq pts (acet-geom-pline-point-list ee nil))<br />      ))<br />      (setq ss2 (ssget "CP" pts))<br />      (ssdel ee ss2)<br />      (command "Chprop" ss2 "" "La" "1" "c" "ByLayer" "")<br />     )<br /> ) <br />

yunfengning

CAD2004测试无反应。大侠加油哈。

Andyhon

看来有些功课得补上
1. (defun dxf ....
2. ET (acet-***) 得靠它
论坛上有很多资料 加油

yunfengning

7楼llsheng_73的程序CAD2004测试符合要求，多谢哈。

emk

这样改，图层不是乱了，