[求助]让程序在运行的过程中支持＂鼠标捕捉＂

jaminth

下面是"zml84"博客上的一个LISP程序....

求助各位版主,,能否改进一下,让程序在运行的过程中支持＂鼠标捕捉＂功能！

多条橡皮筋.lsp

---

;|;;要求：
如同CAD中选择实体的“WP”功能，在绘制任意多边形时，鼠标在屏幕上拾取点的时候，
总是同时和上一点以及第一点相连，在任何时候看都是一个多边形。
;;;==============================================================================
(defun
			C:TT
			()
    (if	(and
			(setq
			PT1
			(getpoint
			"\n起始点: "))
	     (setq
			PT2
			(getpoint
			PT1
			"\n指定下一点: "))
	)
	(progn
	    (command
			"_.pline"
			"non"
			PT1
			"non"
			PT2)
	    (setq
			TEST
			t)
	    (while
			TEST
		(setq
			TMP
			(grread
			t
			7
			0))
		(redraw)
		(cond
			((=
			(car
			TMP)
			3)
			;_左键
		       (setq
			PT2
			(cadr
			TMP))
		       (command
			"non"
			PT2)
		      )
		      ((=
			(car
			TMP)
			11)
			;_右键
		       (command
			"c")
		       (setq
			TEST
			NIL)
		      )
		      ((=
			(car
			TMP)
			5)
			;_移动
		       (setq
			PT
			(cadr
			TMP))
		       (grdraw
			PT
			PT1
			1
			1)
		       (grdraw
			PT
			PT2
			2)
		      )
		)
	    )
			;_结束 while
	)
    )
    (princ)
)

danxingpen

(osnap (getpoint) "_end"),,,其它同理

ZZXXQQ

这样试试：

3. (defun C:TT ()
4. (if (and (setq PT1 (getpoint "\n起始点: "))
5.          (setq PT2 (getpoint PT1 "\n指定下一点: "))) (progn
6. (command "_.pline" PT1 PT2)
7. (setq TEST t)
8. (while TEST
9.   (setq TMP (grread t 7 0))
10.   (redraw)
11.   (cond
12.    ((= (car TMP) 3)   ;_左键
13.     (setq PT2 (cadr   TMP))
14.     (command PT2)
15.    )
16.    ((= (car TMP) 11)   ;_右键
17.     (command "c")
18.     (setq TEST NIL)
19.    )
20.    ((= (car TMP) 5)   ;_移动
21.     (setq PT (cadr TMP))
22.     (grdraw PT PT1 1 1)
23.     (grdraw PT PT2 2)
24.    )
25.   )
26. )   ;_结束 while
27. ))
28. (princ)
29. )

(defun C:TT () (if (and (setq PT1 (getpoint "\n起始点: "))          (setq PT2 (getpoint PT1 "\n指定下一点: "))) (progn (command "_.pline" PT1 PT2) (setq TEST t) (while TEST   (setq TMP (grread t 7 0))   (redraw)   (cond    ((= (car TMP) 3)   ;_左键     (setq PT2 (cadr   TMP))     (command PT2)    )    ((= (car TMP) 11)   ;_右键     (command "c")     (setq TEST NIL)    )    ((= (car TMP) 5)   ;_移动     (setq PT (cadr TMP))     (grdraw PT PT1 1 1)     (grdraw PT PT2 2)    )   ) )   ;_结束 while )) (princ) )

jaminth

根据各位的提示,我自己把程序改进了一下!虽然可以实现想要的捕捉效果...可问题又出现了:
就是当在键盘上按下u时,如何撤销上一个点的问题?!就像画多义线的样子,可以取消一个点!

2. (defun C:TT ()
3. (if (and (setq PT1 (getpoint "\n起始点: "))
4.           (setq PT2 (getpoint PT1 "\n指定下一点: "))) (progn
5.   (command "_.pline" PT1 PT2)
6.   (setq TEST t)
7.   (while TEST
8.    (setq TMP (grread t 7 0))
9.    (redraw)
10.    (cond
11.     ((= (car TMP) 3)   ;_左键
12.   (setq PT2 (cadr TMP))
13.      (command PT2)
14.     )
15.     ((= (car TMP) 12)   ;_右键
16.   (if (/= tmp2 nil)
17.   (progn
18.     (setq PT2 tmp2 tmp2 nil)
19.        (command PT2)
20.   ))
21.     )
22.     ((= (car TMP) 2)   ;_键盘
23.      (command "c")
24.      (setq TEST NIL)
25.     )
26.     ((= (car TMP) 5)   ;_移动
27.   (if (setq pt (osnap (cadr TMP) "cen,end,mid"));_捕捉
28.    (progn
29.    (setq tmp2 pt)
30.          (grdraw PT PT1 1 1)
31.          (grdraw PT PT2 2)
32.     )
33.    (progn
34.          (setq PT (cadr TMP))
35.          (grdraw PT PT1 1 1)
36.          (grdraw PT PT2 2)
37.    )
38.   )
39.     )
40.     )
41.   )   ;_结束 while
42. ))
43.   (princ)
44. )

(defun C:TT () (if (and (setq PT1 (getpoint "\n起始点: "))           (setq PT2 (getpoint PT1 "\n指定下一点: "))) (progn   (command "_.pline" PT1 PT2)   (setq TEST t)   (while TEST    (setq TMP (grread t 7 0))    (redraw)    (cond     ((= (car TMP) 3)   ;_左键   (setq PT2 (cadr TMP))      (command PT2)     )     ((= (car TMP) 12)   ;_右键   (if (/= tmp2 nil)   (progn     (setq PT2 tmp2 tmp2 nil)        (command PT2)   ))     )     ((= (car TMP) 2)   ;_键盘      (command "c")      (setq TEST NIL)     )     ((= (car TMP) 5)   ;_移动   (if (setq pt (osnap (cadr TMP) "cen,end,mid"));_捕捉    (progn    (setq tmp2 pt)          (grdraw PT PT1 1 1)          (grdraw PT PT2 2)     )    (progn          (setq PT (cadr TMP))          (grdraw PT PT1 1 1)          (grdraw PT PT2 2)    )   )     )     )   )   ;_结束 while ))   (princ) )

无痕

;我只说一次

(vlax-invoke (vla-get-activedocument(vlax-get-acad-object))'SendCommand "(ssget) wp ")

jaminth

无痕版主，我不是想要"(ssget) wp "，我是想要画ＰＬＩＮＥ时，也能像＂ＷＰ＂的效果！

ZZXXQQ

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0

jaminth

ZZXXQQ

7楼已改。

jaminth

谢谢谢谢谢谢!!