设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 根据朗大师的动态引线标注2.0修改的引线工具
12345678910下一页
返回列表 发新帖
楼主: springwillow

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

  [复制链接]
自贡黄明儒
发表于 2014-1-20 14:35 | 显示全部楼层
本帖最后由 自贡黄明儒 于 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.   )

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

本帖子中包含更多资源

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

x

点评

Q1241274614
黄大师，能不能按照文字的最左下端，取反应器的点。同时2个文字能不能互动，移动那个都另外一个跟着跑！  发表于 2014-9-1 18:02
回复 支持 反对

使用道具 举报

springwillow
 楼主| 发表于 2014-1-21 12:50 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习，我也来一个上下标注

不错的坐标标注工具，带反应器的。
回复 支持 反对

使用道具 举报

香田里浪人
发表于 2014-2-15 14:38 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习，我也来一个上下标注

不错的坐标标注工具，带反应器的。可是标注的是数学坐标而不是地理坐标，把X和Y互换可成为地理坐标，还有就是线长不能随文字。
回复 支持 反对

使用道具 举报

彳余
发表于 2014-3-21 14:01 | 显示全部楼层

不错的工具,正在用哦
回复 支持 反对

使用道具 举报

tanle2020
发表于 2014-9-1 13:13 | 显示全部楼层
edata 发表于 2014-1-18 13:44
CAD的引线+多行文字效果

求大侠的程序，邮箱860508101@qq.com
回复 支持 反对

使用道具 举报

edata
发表于 2014-9-1 16:59 | 显示全部楼层
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.   )
回复 支持 反对

使用道具 举报

lucas_3333
发表于 2014-9-1 17:20 | 显示全部楼层
自贡黄明儒 发表于 2014-1-20 14:35
向楼主学习，我也来一个上下标注

只能在WCS下工作，没什么意义啊，要重设座标原点怎办？
回复 支持 反对

使用道具 举报

lucas_3333
发表于 2014-9-1 17:25 | 显示全部楼层
edata 发表于 2014-9-1 16:59
我的是中心对齐

E大，这个只是一个对齐程序吧
回复 支持 反对

使用道具 举报

用户5419086408
发表于 2015-1-15 15:00 | 显示全部楼层
有bug,不能标记，可以动态显示，确定后什么都没有！我的CAD是2015版
回复 支持 反对

使用道具 举报

dbqtju
发表于 2015-3-4 08:12 | 显示全部楼层
很不错的程序。早晚会用到的。
回复 支持 反对

使用道具 举报

12345678910下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-4-26 23:41 , Processed in 0.198271 second(s), 20 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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