求高手编写LISP程序

fhcd88

求高手编写LISP程序，请下载
程序要求：在附件中用鼠标点绘形成如红线多边形选择框，在与其他线相交处打断其他线，保留红线框内多线段，红线框外线段删除。
选择框可用请用如下代码生成：
  (setq gpt (getpoint "\n 第一圈围点: ") lst (list gpt))
  (while gpt
    (initget 32)
    (princ "\n 指定直线的端点: ")
    (if (setq gpt (getpoint gpt "\n 指定直线的端点: "))
      (progn
    (setq lst (cons gpt lst))
    (redraw);;;
    (mapcar '(lambda (p1 p2)
               (grvecs (list -7 p1 p2))
             )
             lst
             (append (cdr lst) (list (car lst)))
    )
      )
    )
  )

Andyhon

Try only ...

2. 
   
3. (vl-load-com)
   
4. (Defun c:test ()
   
5.    (setq pt (getpoint "\n第一圈围点: "))
   
6.    (command "pline" pt)
   
7.    (while (= (logand (getvar "CmdActive") 1) 1) (command pause))
   
8.    (setq ee (entlast))
   
9.    (setq ;; (entsel "\n 选取红线多边形选择框: ")
   
10.         obj (vlax-ename->vla-object ee)   ; obj
    
11.    )
    
12.    (vla-offset obj 1)
    
13.    (setq aa1  (vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))
    
14.    (vla-offset obj -1)
    
15.    (setq aa2  (vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))
    
16.    (if (< aa2 aa1)
    
17.      (setq eee ee1)
    
18.      (setq eee ee2)
    
19.    )
    
20.    (setq pts (acet-geom-pline-point-list eee nil))
    
21.    (entdel ee1)
    
22.    (entdel ee2)
    
23.    
    
24.    (SetVar 'OsMode 0)
    
25.    (repeat 2
    
26.      (command "trim" ee "" "f")
    
27.      (mapcar 'command pts)
    
28.      (command "" "")
    
29.    )
    
30. )

<br /> (vl-load-com)<br /> (Defun c:test ()<br />    (setq pt (getpoint "\n第一圈围点: "))<br />    (command "pline" pt)<br />    (while (= (logand (getvar "CmdActive") 1) 1) (command pause))<br />    (setq ee (entlast))<br />    (setq ;; (entsel "\n 选取红线多边形选择框: ")<br />         obj (vlax-ename->vla-object ee)   ; obj<br />    )<br />    (vla-offset obj 1)<br />    (setq aa1  (vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))<br />    (vla-offset obj -1)<br />    (setq aa2  (vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))<br />    (if (< aa2 aa1) <br />      (setq eee ee1)<br />      (setq eee ee2)<br />    )<br />    (setq pts (acet-geom-pline-point-list eee nil))<br />    (entdel ee1)<br />    (entdel ee2)<br />    <br />    (SetVar 'OsMode 0)<br />    (repeat 2<br />      (command "trim" ee "" "f")<br />      (mapcar 'command pts)<br />      (command "" "")<br />    )<br /> )

ZZXXQQ

给个图样

xsso

留个脚印，等答案！

fhcd88

试了一下，出错，再者能否就使用我贴子中给的绘制选择框的程序啊，请把代码加进去，谢谢

Andyhon

...出错...

得有 Acet-* 函数;
搜 ET / Express Tools

fhcd88

我再试试，能否还是请你完整用我给的绘选择框的代码绘选择框，因为我程序中其他部分在用

Andyhon

2. 
   
3. 
   
4. (Defun test ()
   
5.   (setq gpt (getpoint "\n 第一圈围点: ")
   
6.         lst (list gpt)
   
7.   )
   
8.   (while gpt
   
9.     (initget 32)
   
10.     (princ "\n 指定直线的端点: ")
    
11.     (if (setq gpt (getpoint gpt "\n 指定直线的端点: "))
    
12.       (progn
    
13.         (setq lst (cons gpt lst))
    
14.         (redraw)
    
15.         (mapcar '(lambda (p1 p2)
    
16.                    (grvecs (list -7 p1 p2))
    
17.                  )
    
18.                 lst
    
19.                 (append (cdr lst) (list (car lst)))
    
20.         )
    
21.       )
    
22.     )
    
23.   )
    
24.   lst
    
25. )
    
26. 
    
27. (Defun c:test ()
    
28.    ;; (setq pt (getpoint "\n第一圈围点: "))
    
29.    (setq pts (test))
    
30.    (command "pline")
    
31.    (mapcar 'command pts)
    
32.    (command "C")
    
33.    (setq ee (entlast))
    
34.    ;; 红线多边形选择框请先绘制
    
35.    (setq ;; (entsel "\n 选取红线多边形选择框: ")
    
36.         obj (vlax-ename->vla-object ee)   ; obj
    
37.    )
    
38.    (vla-offset obj 1)
    
39.    (setq aa1  (vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))
    
40.    (vla-offset obj -1)
    
41.    (setq aa2  (vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))
    
42.    (if (< aa2 aa1)
    
43.      (setq eee ee1)
    
44.      (setq eee ee2)
    
45.    )
    
46.    (setq pts (acet-geom-pline-point-list eee nil))
    
47.    (entdel ee1)
    
48.    (entdel ee2)
    
49.    (SetVar 'OsMode 0)
    
50.    (repeat 2
    
51.      (command "trim" ee "" "f")
    
52.      (mapcar 'command pts)
    
53.      (command "" "")
    
54.    )
    
55.    (redraw)
    
56.    (entdel ee)
    
57.    (setq ss (ssget "WP" pts))
    
58. )

<br /> <br /> (Defun test ()<br />   (setq gpt (getpoint "\n 第一圈围点: ")<br />         lst (list gpt)<br />   )<br />   (while gpt<br />     (initget 32)<br />     (princ "\n 指定直线的端点: ")<br />     (if (setq gpt (getpoint gpt "\n 指定直线的端点: "))<br />       (progn<br />         (setq lst (cons gpt lst))<br />         (redraw)<br />         (mapcar '(lambda (p1 p2)<br />                    (grvecs (list -7 p1 p2))<br />                  )<br />                 lst<br />                 (append (cdr lst) (list (car lst)))<br />         )<br />       )<br />     )<br />   )<br />   lst<br /> )<br /> <br /> (Defun c:test ()<br />    ;; (setq pt (getpoint "\n第一圈围点: "))<br />    (setq pts (test))<br />    (command "pline")<br />    (mapcar 'command pts)<br />    (command "C")<br />    (setq ee (entlast))<br />    ;; 红线多边形选择框请先绘制<br />    (setq ;; (entsel "\n 选取红线多边形选择框: ")<br />         obj (vlax-ename->vla-object ee)   ; obj<br />    )<br />    (vla-offset obj 1)<br />    (setq aa1  (vla-get-area (vlax-ename->vla-object (setq ee1 (entlast)))))<br />    (vla-offset obj -1)<br />    (setq aa2  (vla-get-area (vlax-ename->vla-object (setq ee2 (entlast)))))<br />    (if (< aa2 aa1)<br />      (setq eee ee1)<br />      (setq eee ee2)<br />    )<br />    (setq pts (acet-geom-pline-point-list eee nil))<br />    (entdel ee1)<br />    (entdel ee2)<br />    (SetVar 'OsMode 0)<br />    (repeat 2<br />      (command "trim" ee "" "f")<br />      (mapcar 'command pts)<br />      (command "" "")<br />    )<br />    (redraw)<br />    (entdel ee)<br />    (setq ss (ssget "WP" pts))<br /> )

fhcd88

能否再帮忙加两行代码，一是做一个选择集选择所绘框内所有图元，含框线经过的图元；二是，删除所绘框，谢谢

fhcd88

能加上后面的代码的话，可以就用你前面的程序直接绘框