本帖最后由 自贡黄明儒 于 2014-1-20 14:50 编辑
向楼主学习，我也来一个上下标注
(defun C:mybz (/ HAND MOBJ MSPACE MTEXTH MTEXTOBJ OBJ P1 P2 PT2 PT3 PTS)
(defun gx (obj vlrobj data/ AOBJ INSPT P1 PT1)
(if (and (not (vlax-erased-p obj))
(setq Aobj (vlax-get-property obj 'Annotation))
) ;判断对象是否被删除
(progn
(setq pt1 (vlax-get-property obj 'Coordinate 0))
(setq p1 (vlax-safearray->list (vlax-variant-value pt1)))
(vlax-put Aobj 'TextString (strcat "X=" (rtos (car p1) 2 1)))
(setq insPT (vlax-get Aobj 'InsertionPoint))
(setq obj (vlax-ename->vla-object (handent (car (vlr-data vlrobj)))))
(vlax-put obj 'TextString (strcat "Y=" (rtos (cadr p1) 2 1)))
(setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT")))
(vlax-put obj 'InsertionPoint (mapcar '- insPT (list 0 (+ MtextH 2) 0)))
)
)
)
(setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT"))) ;文字高度为当前标柱样式文字高度*全局比例
(setq p1 (getpoint "\n选择要标注的点:"))
(setq p2 (getpoint p1 "\n选择标注文字位置:"))
(setq pt2 (vlax-3D-point p2))
(setq pt3 (vlax-3D-point (mapcar '- p2 (list 0 (+ MtextH 0.5)))))
(setq Mtextobj (vla-addMtext mSpace pt2 0.0 (strcat "X=" (rtos (car p1) 2 1))))
(vlax-put Mtextobj 'Height MtextH)
(setq Mobj (vla-addMtext mSpace pt3 0.0 (strcat "Y=" (rtos (cadr p1) 2 1))))
(vlax-put Mobj 'Height MtextH)
(setq hand (vlax-get Mobj 'Handle))
(if (> (car p1) (car p2))
(progn(vlax-put Mtextobj 'AttachmentPoint 9)(vlax-put Mobj 'AttachmentPoint 9))
(progn(vlax-put Mtextobj 'AttachmentPoint 7)(vlax-put Mobj 'AttachmentPoint 7))
)
(vlax-put Mtextobj 'InsertionPoint p2);(vlax-put-property Mtextobj 'InsertionPoint pt2)
(setq pts (vlax-make-safearray vlax-vbDouble '(0 . 5)))
(vlax-safearray-fill
pts
(list (car p1) (cadr p1) (caddr p1) (car p2) (cadr p2) (caddr p2))
)
(setq obj (vla-Addleader mSpace pts Mtextobj acLineWithArrow))
(vlr-object-reactor (list obj) (list hand) '((:vlr-modified . gx)))
(princ)
)
自贡黄明儒 发表于 2014-1-20 14:35 static/image/common/back.gif
向楼主学习，我也来一个上下标注
不错的坐标标注工具，带反应器的。
自贡黄明儒 发表于 2014-1-20 14:35 static/image/common/back.gif
向楼主学习，我也来一个上下标注
不错的坐标标注工具，带反应器的。可是标注的是数学坐标而不是地理坐标，把X和Y互换可成为地理坐标，还有就是线长不能随文字。
不错的工具,正在用哦
edata 发表于 2014-1-18 13:44 static/image/common/back.gif
CAD的引线+多行文字效果
求大侠的程序，邮箱860508101@qq.com
tanle2020 发表于 2014-9-1 13:13 static/image/common/back.gif
求大侠的程序，邮箱
我的是中心对齐
;;三点引线与多行文字中心线对齐
(defun c:tt(/ aplst e e2 ee en en2 ex ey ez txt42 txt43)
(setq aplst '(-3 ("ACAD" (1000 . "DSTYLE") (1002 . "{") (1070 . 147) (1040 . 0.0) (1070 . 77) (1070 . 1) (1002 . "}"))))
(if (and(setq en(car(entsel "\n选择引线:")))
(EQUAL(assoc 0 (entget en)) '(0 . "LEADER"))
(setq en2(car(entsel "\n多行文字:")))
(EQUAL(assoc 0 (entget en2)) '(0 . "MTEXT"))
)
(progn
(setq e2(entget en2))
(setq e(entget en '("*")))
(setq ex (list(car e2)(cadr e2)(caddr e2))
ey(list'(102 . "{ACAD_REACTORS")(cons 330 en) '(102 . "}"))
ez(cdddr e2)
ee(append ex ey ez)
txt42(cdr(assoc 42 e2));宽度
txt43(cdr(assoc 43 e2));高度
e10 (cdr(assoc 10 e2))
p13(polar e10 (* pi 1.5) (* txt43 0.5))
)
(setq elst '() i 0 pts '())
(while (setq a(car e))
(setq b(cdr a))
(if(= (car a) 10)
(setq i(1+ i) pts(cons b pts))
)
(if(and (= (car a) 10) (or (= i 2) (= i 3)))
(progn (setq elst(cons (cons 10 (list (car b)(cadr p13) 0))elst)))
(setq elst(cons a elst))
)
(setq e(cdr e))
)
(setq e(reverse elst) pts(reverse pts))
(setq ang1(angle (car pts)(cadr pts)))
(if(and (> ang1 (* pi 0.5)) (< ang1 (* pi 1.5)))
(setq e213 (list (* txt42 -1)(* txt43 0.5) 0))
(setq e213 (list txt42(* txt43 0.5) 0))
)
(setq e(subst(cons 340 en2)(assoc 340 e)e))
(setq e(subst(cons 213 e213)(assoc 213 e)e))
(if (assoc -3 e)
(setq e(subst aplst (assoc -3 e) e))
(setq e(reverse (cons (reverse aplst) e)))
);附加数据
(entmod e)
(entmod ee)
)
)
(princ)
)
自贡黄明儒 发表于 2014-1-20 14:35 static/image/common/back.gif
向楼主学习，我也来一个上下标注
只能在WCS下工作，没什么意义啊，要重设座标原点怎办？
edata 发表于 2014-9-1 16:59 static/image/common/back.gif
我的是中心对齐
E大，这个只是一个对齐程序吧
有bug,不能标记，可以动态显示，确定后什么都没有！我的CAD是2015版
很不错的程序。早晚会用到的。