[日积月累]：实时跟踪光标小结！

panzhongw

在论坛上看了部分关于实时跟踪光标的帖子，很受启发
现归结为以下程序，希望对大家有用！

lijiao

最初由 panzhongw 发布
[B]在论坛上看了部分关于实时跟踪光标的帖子，很受启发
现归结为以下程序，希望对大家有用！ [/B]

你的代码不应叫“实时跟踪光标”，应叫“拖动”，代码中有多处错误，我已经修改好了。

2. 
   
3.   [FONT=courier new]
   
4. ;;;0.01 (2003.3.31) for r2002
   
5. ;;;测试GRREAD
   
6. (defun c:t1 (/ pt1 pt2 ls line1 ts1 ds ts2 tx1 tx2 pick p ip pt p1)
   
7.   (setvar "CMDECHO" 0)
   
8.   (setq pt1 (getpoint "\please input pt1"))
   
9.   (while (= 0 (distance (setq pt2 (cadr (grread t 4 0))) pt1))
   
10.   )
    
11.   (command "line" pt1 pt2 "")
    
12.   (setq ls (entlast))
    
13.   (setq line1 (entget ls))
    
14.   (setq ts1 "  long=")
    
15.   (setq ds (rtos (distance pt1 pt2) 2 2))
    
16.   (setq ts2 (strcat ts1 ds))
    
17.   (command "text" pt2 (/ (getvar "viewsize") 40.0) "" ts2)
    
18.   (setq tx1 (entlast))
    
19.   (vla-put-color (vlax-ename->vla-object tx1) 1)
    
20.   (setq tx2 (entget tx1))
    
21.   (setq pick nil)
    
22.   (while (not pick)
    
23.     (setq p (grread t 4 0))
    
24.     (princ)
    
25.     (setq ip (car p))
    
26.     (setq pt (cadr p))
    
27.     (if        (= ip 5)
    
28. ;;;;;;;;;;;;;;确定为坐标移动
    
29.       (progn
    
30.         (setq p1 (trans pt 1 0))
    
31.         ;;坐标系转换（以防止更新数据表时出错）
    
32.         (setq line1 (subst (cons 11 p1) (assoc 11 line1) line1))
    
33.         (entmod line1)
    
34.         (setq ds (rtos (distance pt1 p1) 2 2))
    
35.         (setq ts2 (strcat ts1 ds))
    
36.         (setq tx2 (subst (cons 10 p1) (assoc 10 tx2) tx2))
    
37.         (setq tx2 (subst (cons 1 ts2) (assoc 1 tx2) tx2))
    
38.         (setq tx2 (subst (cons 40 (/ (getvar "viewsize") 40.0)) (assoc 40 tx2) tx2))
    
39.         (entmod tx2)
    
40.       )
    
41.       ;;progn
    
42.     )
    
43.     ;;if
    
44.     (setq pick (= 3 ip))
    
45. ;;;;;确定为点取坐标
    
46.   )
    
47.   ;;while
    
48.   (entdel tx1)
    
49.   (setvar "CMDECHO" 1)
    
50.   (princ)
    
51. )
    
52.   [/FONT]
    

<br />   [FONT=courier new]<br /> ;;;0.01 (2003.3.31) for r2002<br /> ;;;测试GRREAD<br /> (defun c:t1 (/ pt1 pt2 ls line1 ts1 ds ts2 tx1 tx2 pick p ip pt p1)<br />   (setvar "CMDECHO" 0)<br />   (setq pt1 (getpoint "\please input pt1"))<br />   (while (= 0 (distance (setq pt2 (cadr (grread t 4 0))) pt1))<br />   )<br />   (command "line" pt1 pt2 "")<br />   (setq ls (entlast))<br />   (setq line1 (entget ls))<br />   (setq ts1 "  long=")<br />   (setq ds (rtos (distance pt1 pt2) 2 2))<br />   (setq ts2 (strcat ts1 ds))<br />   (command "text" pt2 (/ (getvar "viewsize") 40.0) "" ts2)<br />   (setq tx1 (entlast))<br />   (vla-put-color (vlax-ename->vla-object tx1) 1)<br />   (setq tx2 (entget tx1))<br />   (setq pick nil)<br />   (while (not pick)<br />     (setq p (grread t 4 0))<br />     (princ)<br />     (setq ip (car p))<br />     (setq pt (cadr p))<br />     (if        (= ip 5)<br /> ;;;;;;;;;;;;;;确定为坐标移动<br />       (progn<br />         (setq p1 (trans pt 1 0))<br />         ;;坐标系转换（以防止更新数据表时出错）<br />         (setq line1 (subst (cons 11 p1) (assoc 11 line1) line1))<br />         (entmod line1)<br />         (setq ds (rtos (distance pt1 p1) 2 2))<br />         (setq ts2 (strcat ts1 ds))<br />         (setq tx2 (subst (cons 10 p1) (assoc 10 tx2) tx2))<br />         (setq tx2 (subst (cons 1 ts2) (assoc 1 tx2) tx2))<br />         (setq tx2 (subst (cons 40 (/ (getvar "viewsize") 40.0)) (assoc 40 tx2) tx2))<br />         (entmod tx2)<br />       )<br />       ;;progn<br />     )<br />     ;;if<br />     (setq pick (= 3 ip))<br /> ;;;;;确定为点取坐标<br />   )<br />   ;;while<br />   (entdel tx1)<br />   (setvar "CMDECHO" 1)<br />   (princ)<br /> )<br />   [/FONT]<br />

panzhongw

深谢！
原本只是想测试一下，不想真达到了抛砖引玉的功果！
lijiao兄还望今后不吝赐教！

bridgewind

不错！刚好解决我的一个问题。
向你学习！

jx2008

1楼的程序执行起来没有错误,到是2楼你的程序执行起来错误多处.请你更正.

zlzlzlzl

好象用不到```
不过同意楼上的意见`

gccghl

cad2006已经有该功能了，似乎不太需要在加该lisp，只有在低版本的cad中才有用。

WHGF

这种实现思路对人有启发，谢谢个位的讨论！