明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
楼主: springwillow

[源码] 根据朗大师的动态引线标注2.0修改的引线工具

    [复制链接]
发表于 2014-1-20 14:35:06 | 显示全部楼层
本帖最后由 自贡黄明儒 于 2014-1-20 14:50 编辑

向楼主学习,我也来一个上下标注
  1. (defun C:mybz (/ HAND MOBJ MSPACE MTEXTH MTEXTOBJ OBJ P1 P2 PT2 PT3 PTS)
  2.   (defun gx (obj vlrobj data  / AOBJ INSPT P1 PT1)
  3.     (if        (and (not (vlax-erased-p obj))
  4.              (setq Aobj (vlax-get-property obj 'Annotation))
  5.         )                                                              ;判断对象是否被删除
  6.       (progn
  7.         (setq pt1 (vlax-get-property obj 'Coordinate 0))
  8.         (setq p1 (vlax-safearray->list (vlax-variant-value pt1)))
  9.         (vlax-put Aobj 'TextString (strcat "X=" (rtos (car p1) 2 1)))
  10.         (setq insPT (vlax-get Aobj 'InsertionPoint))
  11.         (setq obj (vlax-ename->vla-object (handent (car (vlr-data vlrobj)))))
  12.         (vlax-put obj 'TextString (strcat "Y=" (rtos (cadr p1) 2 1)))
  13.         (setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT")))        
  14.         (vlax-put obj 'InsertionPoint (mapcar '- insPT (list 0 (+ MtextH 2) 0)))
  15.       )
  16.     )
  17.   )

  18.   (setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
  19.   (setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT")))              ;文字高度为当前标柱样式文字高度*全局比例  
  20.   (setq p1 (getpoint "\n选择要标注的点:"))
  21.   (setq p2 (getpoint p1 "\n选择标注文字位置:"))
  22.   (setq pt2 (vlax-3D-point p2))
  23.   (setq pt3 (vlax-3D-point (mapcar '- p2 (list 0 (+ MtextH 0.5)))))
  24.   (setq Mtextobj (vla-addMtext mSpace pt2 0.0 (strcat "X=" (rtos (car p1) 2 1))))
  25.   (vlax-put Mtextobj 'Height MtextH)
  26.   (setq Mobj (vla-addMtext mSpace pt3 0.0 (strcat "Y=" (rtos (cadr p1) 2 1))))
  27.   (vlax-put Mobj 'Height MtextH)
  28.   (setq hand (vlax-get Mobj 'Handle))
  29.   (if (> (car p1) (car p2))
  30.     (progn(vlax-put Mtextobj 'AttachmentPoint 9)(vlax-put Mobj 'AttachmentPoint 9))
  31.     (progn(vlax-put Mtextobj 'AttachmentPoint 7)(vlax-put Mobj 'AttachmentPoint 7))
  32.   )
  33.   (vlax-put Mtextobj 'InsertionPoint p2);(vlax-put-property Mtextobj 'InsertionPoint pt2)
  34.   (setq pts (vlax-make-safearray vlax-vbDouble '(0 . 5)))
  35.   (vlax-safearray-fill
  36.     pts
  37.     (list (car p1) (cadr p1) (caddr p1) (car p2) (cadr p2) (caddr p2))
  38.   )
  39.   (setq obj (vla-Addleader mSpace pts Mtextobj acLineWithArrow))  
  40.   (vlr-object-reactor (list obj) (list hand) '((:vlr-modified . gx)))  
  41.   (princ)
  42. )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

黄大师,能不能按照文字的最左下端,取反应器的点。同时2个文字能不能互动,移动那个都另外一个跟着跑!  发表于 2014-9-1 18:02
 楼主| 发表于 2014-1-21 12:50:22 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习,我也来一个上下标注

不错的坐标标注工具,带反应器的。
发表于 2014-2-15 14:38:22 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习,我也来一个上下标注

不错的坐标标注工具,带反应器的。可是标注的是数学坐标而不是地理坐标,把X和Y互换可成为地理坐标,还有就是线长不能随文字。
发表于 2014-3-21 14:01:18 | 显示全部楼层

不错的工具,正在用哦
发表于 2014-9-1 13:13:42 | 显示全部楼层
edata 发表于 2014-1-18 13:44
CAD的引线+多行文字效果

求大侠的程序,邮箱860508101@qq.com
发表于 2014-9-1 16:59:21 | 显示全部楼层
tanle2020 发表于 2014-9-1 13:13
求大侠的程序,邮箱

我的是中心对齐
  1. ;;三点引线与多行文字中心线对齐
  2. (defun c:tt(/ aplst e e2 ee en en2 ex ey ez txt42 txt43)
  3.   (setq aplst '(-3 ("ACAD" (1000 . "DSTYLE") (1002 . "{") (1070 . 147) (1040 . 0.0) (1070 . 77) (1070 . 1) (1002 . "}"))))
  4.   (if (and(setq en(car(entsel "\n选择引线:")))
  5.           (EQUAL(assoc 0 (entget en)) '(0 . "LEADER"))
  6.           (setq en2(car(entsel "\n多行文字:")))
  7.           (EQUAL(assoc 0 (entget en2)) '(0 . "MTEXT"))
  8.           )
  9.     (progn
  10.       (setq e2(entget en2))
  11.       (setq e(entget en '("*")))
  12.       (setq ex (list(car e2)(cadr e2)(caddr e2))
  13.             ey(list'(102 . "{ACAD_REACTORS")(cons 330 en) '(102 . "}"))
  14.             ez(cdddr e2)
  15.             ee(append ex ey ez)
  16.             txt42(cdr(assoc 42 e2));宽度
  17.             txt43(cdr(assoc 43 e2));高度
  18.             e10 (cdr(assoc 10 e2))
  19.             p13(polar e10 (* pi 1.5) (* txt43 0.5))
  20.             )
  21.       (setq elst '()   i 0 pts '())
  22.       (while (setq a(car e))
  23.         (setq b(cdr a))
  24.         (if(= (car a) 10)
  25.           (setq i(1+ i) pts(cons b pts))
  26.           )
  27.         (if(and (= (car a) 10) (or (= i 2) (= i 3)))
  28.           (progn (setq elst(cons (cons 10 (list (car b)(cadr p13) 0))elst)))
  29.           (setq elst(cons a elst))
  30.           )
  31.         (setq e(cdr e))
  32.         )
  33.       (setq e(reverse elst) pts(reverse pts))
  34.       (setq ang1(angle (car pts)(cadr pts)))
  35.       (if(and (> ang1 (* pi 0.5)) (< ang1 (* pi 1.5)))
  36.         (setq e213 (list (* txt42 -1)  (* txt43 0.5) 0))
  37.         (setq e213 (list txt42  (* txt43 0.5) 0))
  38.         )
  39.       (setq e(subst(cons 340 en2)(assoc 340 e)e))
  40.       (setq e(subst(cons 213 e213)(assoc 213 e)e))
  41.       (if (assoc -3 e)
  42.         (setq e(subst aplst (assoc -3 e) e))
  43.         (setq e(reverse (cons (reverse aplst) e)))
  44.         );附加数据
  45.       (entmod e)
  46.       (entmod ee)
  47.       )
  48.     )
  49.   (princ)
  50.   )
发表于 2014-9-1 17:20:05 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习,我也来一个上下标注

只能在WCS下工作,没什么意义啊,要重设座标原点怎办?
发表于 2014-9-1 17:25:44 | 显示全部楼层
edata 发表于 2014-9-1 16:59
我的是中心对齐

E大,这个只是一个对齐程序吧
发表于 2015-1-15 15:00:28 | 显示全部楼层
有bug,不能标记,可以动态显示,确定后什么都没有!我的CAD是2015版
发表于 2015-3-4 08:12:36 | 显示全部楼层
很不错的程序。早晚会用到的。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-11-15 07:06 , Processed in 0.166703 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表