求任意拖动文字程序

cj52000

各位师兄，如下图，工作中经常要调整注解文字位置，常规做法是M移动，选中文字找基点，然后移动，大批量操作还是很繁琐，偶尔看到一个叫“拉移随心”程序，直接点文字，文字就跟着鼠标走，再点下就到目的地，很是方便，能否帮忙写个程序，谢谢！

和尚777

(defun c:tt ()
        (if(setq e(entsel))
                (command "move" (car e)""(cadr e) pause)
        )(princ)
)

夏生生

给您几个函数，拼凑一下
(setq *xty-o2e* vlax-ename->vla-object *xty-e2o* vlax-vla-object->ename)

2. ;;;      通用函数  动态移动
   
3. ;;;参数： ss---------选择集、图元名、或图元名表
   
4. ;;;       grmode-----grread参数
   
5. ;;;       from-------移动基点UCS
   
6. ;;;       vx----------是否平行向量，Vx平行该向量，nil任意
   
7. ;;;       vy----------是否垂直向量，1平行，2垂直,3垂直或平行
   
8. ;;;返回值：ss
   
9. (defun xty-gr-move (ss grmode from vx vy / enlst gr loop pt pts)
   
10.   (cond        ((eq (type ss) 'PICKSET) (setq enlst (xty-tr-ss2lst ss t)))
    
11.         ((eq (type ss) 'ENAME) (setq enlst (list ss)))
    
12.         ((eq (type ss) 'LIST) (setq enlst ss))
    
13.         )
    
14.   (setq        loop t
    
15.         pts  from
    
16.         )
    
17.   (while loop
    
18.     (setq gr (apply 'grread grmode)
    
19.           pt (cadr gr)
    
20.           gr (car gr)
    
21.           )
    
22.     (cond ((= gr 5) ;_当鼠标移动
    
23.            (if vx
    
24.              (progn (setq pt (xty-G-Orthopttov from pt vx))
    
25.                     (cond ((= 1 vy) (setq pt (cadr pt))) ;_平行(ucs)
    
26.                           ((= 2 vy) (setq pt (caddr pt))) ;_垂直(ucs)
    
27.                           ((= 3 vy) (setq pt (car pt))) ;_—垂直或平行wcs)
    
28.                           )
    
29.                     )
    
30.              )
    
31.            (foreach n enlst (xty-move n pts pt)) ;_移动一个向量
    
32.            (setq pts pt) ;_向量的相对移动
    
33.            )
    
34.           ((= gr 3) (setq loop nil)) ;_鼠标左键，结束移动
    
35.           (t (setq loop nil)) ;_键盘任意键键，结束移动
    
36.           )
    
37.     )
    
38.   ss
    
39.   )
    

;;;      通用函数  动态移动<br /> ;;;参数： ss---------选择集、图元名、或图元名表<br /> ;;;       grmode-----grread参数<br /> ;;;       from-------移动基点UCS<br /> ;;;       vx----------是否平行向量，Vx平行该向量，nil任意<br /> ;;;       vy----------是否垂直向量，1平行，2垂直,3垂直或平行<br /> ;;;返回值：ss<br /> (defun xty-gr-move (ss grmode from vx vy / enlst gr loop pt pts)<br />   (cond        ((eq (type ss) 'PICKSET) (setq enlst (xty-tr-ss2lst ss t)))<br />         ((eq (type ss) 'ENAME) (setq enlst (list ss)))<br />         ((eq (type ss) 'LIST) (setq enlst ss))<br />         )<br />   (setq        loop t<br />         pts  from<br />         )<br />   (while loop<br />     (setq gr (apply 'grread grmode)<br />           pt (cadr gr)<br />           gr (car gr)<br />           )<br />     (cond ((= gr 5) ;_当鼠标移动<br />            (if vx<br />              (progn (setq pt (xty-G-Orthopttov from pt vx))<br />                     (cond ((= 1 vy) (setq pt (cadr pt))) ;_平行(ucs)<br />                           ((= 2 vy) (setq pt (caddr pt))) ;_垂直(ucs)<br />                           ((= 3 vy) (setq pt (car pt))) ;_—垂直或平行wcs)<br />                           )<br />                     )<br />              )<br />            (foreach n enlst (xty-move n pts pt)) ;_移动一个向量<br />            (setq pts pt) ;_向量的相对移动<br />            )<br />           ((= gr 3) (setq loop nil)) ;_鼠标左键，结束移动<br />           (t (setq loop nil)) ;_键盘任意键键，结束移动<br />           )<br />     )<br />   ss<br />   )<br />

2. ;;;=============================================
   
3. ;;;      通用函数  选择集转图元名或obj表
   
4. ;;;参数： ss------选择集
   
5. ;;;       form----t返回图元名列表nil返回vba对象表
   
6. ;;;返回值：图元名或obj表
   
7. (defun xty-tr-ss2lst (ss form / n en lst)
   
8.   (repeat (setq n (sslength ss))
   
9.     (setq en (ssname ss (setq n (1- n))))
   
10.     (setq lst (cons en lst))
    
11.   )
    
12.   (setq lst(reverse lst))
    
13.   (if form lst (mapcar(function *xty-e2o*)lst))
    
14. )

;;;=============================================<br /> ;;;      通用函数  选择集转图元名或obj表<br /> ;;;参数： ss------选择集<br /> ;;;       form----t返回图元名列表nil返回vba对象表<br /> ;;;返回值：图元名或obj表<br /> (defun xty-tr-ss2lst (ss form / n en lst)<br />   (repeat (setq n (sslength ss))<br />     (setq en (ssname ss (setq n (1- n))))<br />     (setq lst (cons en lst))<br />   )<br />   (setq lst(reverse lst))<br />   (if form lst (mapcar(function *xty-e2o*)lst))<br /> )

2. ;;;=============================================
   
3. ;;;      通用函数  移动图元
   
4. ;;;参数： obj-------图元名、对象或选择集
   
5. ;;;       from------移动自ucs
   
6. ;;;       to--------移动至ucs
   
7. ;;;返回值：obj
   
8. (defun xty-move        (obj from to / a lst)
   
9.   (if (= 'ENAME (type obj))
   
10.     (setq obj (*xty-e2o* obj)
    
11.           a   t
    
12.           )
    
13.     )
    
14.   (cond        ((= 'ENAME (type obj))
    
15.          (setq obj (*xty-e2o* obj)
    
16.                a   t
    
17.                )
    
18.          )
    
19.         ((= 'PICKSET (type obj)) (setq lst (xty-tr-ss2lst obj nil)))
    
20.         )
    
21.   (if (= 2 (length from))
    
22.     (setq from (xty-G-addz from 0))
    
23.     )
    
24.   (if (= 2 (length to))
    
25.     (setq to (xty-G-addz to 0))
    
26.     )
    
27.   (setq        from (vlax-3d-point (trans from 1 0))
    
28.         to   (vlax-3d-point (trans to 1 0))
    
29.         )
    
30.   (if lst
    
31.     (foreach n lst (vlax-invoke-method n 'move from to))
    
32.     (vlax-invoke-method obj 'move from to)
    
33.     )
    
34.   (if a
    
35.     (*xty-o2e* obj)
    
36.     obj
    
37.     )
    
38.   )

;;;=============================================<br /> ;;;      通用函数  移动图元<br /> ;;;参数： obj-------图元名、对象或选择集<br /> ;;;       from------移动自ucs<br /> ;;;       to--------移动至ucs<br /> ;;;返回值：obj<br /> (defun xty-move        (obj from to / a lst)<br />   (if (= 'ENAME (type obj))<br />     (setq obj (*xty-e2o* obj)<br />           a   t<br />           )<br />     )<br />   (cond        ((= 'ENAME (type obj))<br />          (setq obj (*xty-e2o* obj)<br />                a   t<br />                )<br />          )<br />         ((= 'PICKSET (type obj)) (setq lst (xty-tr-ss2lst obj nil)))<br />         )<br />   (if (= 2 (length from))<br />     (setq from (xty-G-addz from 0))<br />     )<br />   (if (= 2 (length to))<br />     (setq to (xty-G-addz to 0))<br />     )<br />   (setq        from (vlax-3d-point (trans from 1 0))<br />         to   (vlax-3d-point (trans to 1 0))<br />         )<br />   (if lst<br />     (foreach n lst (vlax-invoke-method n 'move from to))<br />     (vlax-invoke-method obj 'move from to)<br />     )<br />   (if a<br />     (*xty-o2e* obj)<br />     obj<br />     )<br />   )

2. ;;;=============================================
   
3. ;;;      通用函数  二维点变三维点
   
4. ;;;参数： pt------二维点
   
5. ;;;返回值：二维点
   
6. (defun xty-G-addz (pt z)
   
7.   (list (car pt) (cadr pt) z)
   
8. )

;;;=============================================<br /> ;;;      通用函数  二维点变三维点<br /> ;;;参数： pt------二维点<br /> ;;;返回值：二维点<br /> (defun xty-G-addz (pt z)<br />   (list (car pt) (cadr pt) z)<br /> )

2. ;;;      通用函数  求过基点平行或垂直向量点
   
3. ;;;参数： base------基点wcs
   
4. ;;;       point-----方向点wcs
   
5. ;;;       vx---------方向单位向量wcs
   
6. ;;;返回值：(过基点平行或垂直向量点 过基点平行向量点 过基点垂直向量点)
   
7. (defun xty-G-Orthopttov        (base pt vx / dx dy ptx pty vp vy)
   
8.   (setq        vy  (xty-vec-vxv '(0.0 0.0 1.0) vx) ;_目标向量逆时针旋转90度
   
9.         vp  (xty-vec-v-v pt base)
   
10.         dx  (xty-vec-Dot vx vp) ;_vp向在目标向量上的投影
    
11.         dy  (xty-vec-Dot vy vp) ;_vp向在目标向量垂直向量上的投影
    
12.         ptx (xty-vec-v+v base (xty-vec-vxs vx dx))
    
13.         pty (xty-vec-v+v base (xty-vec-vxs vy dy))
    
14.   )
    
15.   (if (< (abs dx) (abs dy))
    
16.     (list pty ptx pty);_当x投影长度小于y投影长度
    
17.     (list ptx ptx pty);_当x投影长度大于等于y投影长度
    
18.   )
    
19. )

;;;      通用函数  求过基点平行或垂直向量点<br /> ;;;参数： base------基点wcs<br /> ;;;       point-----方向点wcs<br /> ;;;       vx---------方向单位向量wcs<br /> ;;;返回值：(过基点平行或垂直向量点 过基点平行向量点 过基点垂直向量点)<br /> (defun xty-G-Orthopttov        (base pt vx / dx dy ptx pty vp vy)<br />   (setq        vy  (xty-vec-vxv '(0.0 0.0 1.0) vx) ;_目标向量逆时针旋转90度<br />         vp  (xty-vec-v-v pt base)<br />         dx  (xty-vec-Dot vx vp) ;_vp向在目标向量上的投影<br />         dy  (xty-vec-Dot vy vp) ;_vp向在目标向量垂直向量上的投影<br />         ptx (xty-vec-v+v base (xty-vec-vxs vx dx))<br />         pty (xty-vec-v+v base (xty-vec-vxs vy dy))<br />   )<br />   (if (< (abs dx) (abs dy))<br />     (list pty ptx pty);_当x投影长度小于y投影长度<br />     (list ptx ptx pty);_当x投影长度大于等于y投影长度<br />   )<br /> )

2. ;;;=============================================
   
3. ;;;      通用函数  两向量相加
   
4. ;;;参数： v1-------向量
   
5. ;;;       V2-------向量
   
6. ;;;返回值：向量
   
7. ;;;几何意义:三角形法则（唯一的合成）；平行四边形法则（力的合成）
   
8. (defun xty-vec-v+v (v1 v2)
   
9.   (mapcar (function +) v1 v2)
   
10. )
    
11. ;;;=============================================
    
12. ;;;      通用函数  两向量相减
    
13. ;;;参数： v1-------向量
    
14. ;;;       V2-------向量
    
15. ;;;返回值：向量，方向->2终点指向->1终点
    
16. (defun xty-vec-v-v (v1 v2)
    
17.   (mapcar (function -) v1 v2)
    
18. )
    
19. ;;;=============================================
    
20. ;;;      通用函数  两表相乘
    
21. ;;;参数： v1-------表
    
22. ;;;       V2-------表
    
23. ;;;返回值：表内元素相乘的表
    
24. (defun xty-vec-v*v (v1 v2)
    
25.   (mapcar (function *) v1 v2)
    
26. )
    
27. ;;;=============================================
    
28. ;;;      通用函数  两向量的点积（内积）
    
29. ;;;参数： v1-------向量
    
30. ;;;       v2-------向量
    
31. ;;;返回值：标量
    
32. ;;;几何意义:可以用来表征或计算两个向量之间的夹角
    
33. ;;;         以及在->2在->1向量方向上的投影
    
34. ;;;>0夹角0~90；=0垂直；<0夹角90~180
    
35. (defun xty-vec-Dot (v1 v2)
    
36.   (apply (function +) (xty-vec-v*v v1 v2))
    
37. )
    
38. ;;;=============================================
    
39. ;;;      通用函数  两向量的叉积（外积）
    
40. ;;;参数： v1-------三维向量
    
41. ;;;       v2-------三维向量
    
42. ;;;返回值：三维向量
    
43. ;;;几何意义:v1和v2组成的面的法向量
    
44. ;;;         二维时，平行四边形面积
    
45. (defun xty-vec-vxv ( u v )
    
46.   (list
    
47.     (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
    
48.     (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))
    
49.     (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
    
50.   )
    
51. )

;;;=============================================<br /> ;;;      通用函数  两向量相加<br /> ;;;参数： v1-------向量<br /> ;;;       V2-------向量<br /> ;;;返回值：向量<br /> ;;;几何意义:三角形法则（唯一的合成）；平行四边形法则（力的合成）<br /> (defun xty-vec-v+v (v1 v2)<br />   (mapcar (function +) v1 v2)<br /> )<br /> ;;;=============================================<br /> ;;;      通用函数  两向量相减<br /> ;;;参数： v1-------向量<br /> ;;;       V2-------向量<br /> ;;;返回值：向量，方向->2终点指向->1终点<br /> (defun xty-vec-v-v (v1 v2)<br />   (mapcar (function -) v1 v2)<br /> )<br /> ;;;=============================================<br /> ;;;      通用函数  两表相乘<br /> ;;;参数： v1-------表<br /> ;;;       V2-------表<br /> ;;;返回值：表内元素相乘的表<br /> (defun xty-vec-v*v (v1 v2)<br />   (mapcar (function *) v1 v2)<br /> )<br /> ;;;=============================================<br /> ;;;      通用函数  两向量的点积（内积）<br /> ;;;参数： v1-------向量<br /> ;;;       v2-------向量<br /> ;;;返回值：标量<br /> ;;;几何意义:可以用来表征或计算两个向量之间的夹角<br /> ;;;         以及在->2在->1向量方向上的投影<br /> ;;;>0夹角0~90；=0垂直；<0夹角90~180<br /> (defun xty-vec-Dot (v1 v2)<br />   (apply (function +) (xty-vec-v*v v1 v2))<br /> )<br /> ;;;=============================================<br /> ;;;      通用函数  两向量的叉积（外积）<br /> ;;;参数： v1-------三维向量<br /> ;;;       v2-------三维向量<br /> ;;;返回值：三维向量<br /> ;;;几何意义:v1和v2组成的面的法向量<br /> ;;;         二维时，平行四边形面积<br /> (defun xty-vec-vxv ( u v )<br />   (list<br />     (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))<br />     (- (* (car  v) (caddr u)) (* (car  u) (caddr v)))<br />     (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))<br />   )<br /> )

qazxswk

cj52000 发表于 2022-3-17 11:13
谢谢，这个可以命令不中断，一直使用，能否加上使用此命令关闭正交，关闭捕捉

;;;;;在使用时会关闭正交与捕捉，完成或中途取消可以恢复到使用前的状态

(defun c:11 (/  *error* oldort osm e)
(defun *error*( msg )
(if oldort(setvar "orthomode" oldort))
(if osm(setvar "orthomode" osm))
(princ))

(setq oldort (getvar "orthomode"))
(setvar "orthomode" 0)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(while (setq e (entsel))
  (command "move" (car e)""(cadr e) pause)
  )
(setvar "orthomode" oldort)
(setvar "osmode" osm)
(princ)
)

muwind

我一般是选择文字然后选一个夹点， 按下空格就跟着走了，不用输入m ，同样适用于其他各种图元对象，

mikewolf2k

如果没有理解错误的话，不理解那个“拉移随心”程序的意义，鼠标直接拖就是了，什么别的都不需要。
另外如楼上所言，夹点操作也很方便，移动拷贝缩放旋转等都可以。

cghdy

拉移随心一款经典的结构插件，在结构界是殿堂级的。随意拖动文字是其附带的功能，其功能主要是能按规则调整一串文字间的格式，除了文字，标注、闭合多段线、块等很多图元都可以使用。

cghdy

夏生生 发表于 2022-3-11 09:33
给您几个函数，拼凑一下
(setq *xty-o2e* vlax-ename->vla-object *xty-e2o* vlax-vla-object->ename)

大哥能否给个实例，不太会用

夏生生

cghdy 发表于 2022-3-11 11:42
大哥能否给个实例，不太会用

2. (defun c:tt ()
   
3.   (setq        en (entsel)
   
4.         pt (cadr en)
   
5.         en (car en)
   
6.         )
   
7.   (xty-gr-move en '(t 15 0) pt nil nil)
   
8.   )

(defun c:tt ()<br />   (setq        en (entsel)<br />         pt (cadr en)<br />         en (car en)<br />         )<br />   (xty-gr-move en '(t 15 0) pt nil nil)<br />   )

2. (defun c:tt ()
   
3.   (setq        en (entsel)
   
4.         pt (cadr en)
   
5.         en (car en)
   
6.         )
   
7.   (xty-gr-move en '(t 15 0) pt '(0 1 0) 1)
   
8.   )

(defun c:tt ()<br />   (setq        en (entsel)<br />         pt (cadr en)<br />         en (car en)<br />         )<br />   (xty-gr-move en '(t 15 0) pt '(0 1 0) 1)<br />   )

xyp1964

1. (defun c:tt ()
   
2.   (defun dxf (code e) (cdr (assoc code (entget e))))
   
3.   (if (and (setq s1 (car (entsel "\n选择参照文本: ")))
   
4.            (setq tx (dxf 1 s1))
   
5.            (setq ss (ssget (list '(0 . "text") (cons 1 tx))))
   
6.       )
   
7.     (command "move" ss "" (dxf 10 s1) pause)
   
8.   )
   
9.   (princ)
   
10. )

(defun c:tt ()<br />   (defun dxf (code e) (cdr (assoc code (entget e))))<br />   (if (and (setq s1 (car (entsel "\n选择参照文本: ")))<br />            (setq tx (dxf 1 s1))<br />            (setq ss (ssget (list '(0 . "text") (cons 1 tx))))<br />       )<br />     (command "move" ss "" (dxf 10 s1) pause)<br />   )<br />   (princ)<br /> )

言戲無軍

夏生生 发表于 2022-3-11 14:19

no function definition: XTY-VEC-VXS
差个函数 大神