线上文字
我想写一段文字，在文字下自动生成一条多段线，线段长度随文字长度，且文字与线段相关联，当修改或移动文字时，线段跟随变化。请大侠们出手相助！ ;;; =================================================================;;; 文本加下划线
;;; =================================================================
(defun getp1~4(texts / p h r box p1x p1y p2x p2y px py p1 p2 p3 p4)
(setq p (cdr (assoc 10 texts)) ; 文本基点坐标
h (cdr (assoc 40 texts)) ; 文本高度
r (cdr (assoc 50 texts)) ; 文本旋转角度
)
(setq box (textbox texts)) ; 文本框坐标
(setq p1x (car (car box)) ; 文本左下角X坐标
p1y (car (cdr (car box)))
p2x (car (car (cdr box))) ; 文本右上角X坐标
p2y (car (cdr (car (cdr box))))
px (car p)
py (car (cdr p))
)
; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
(setq p1 (list (- px (* h 0.2)) (- py (* h 0.3)) 0.0)) ; 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h 0.3)竖直方向距0.3倍字高。
(setq p2 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.3)) 0.0)) ; 第一条线段右端点坐标
(setq p3 (list (- px (* h 0.2)) (- py (* h 0.56)))) ; 第二条线段左端点坐标
(setq p4 (list (+ p2x (+ px (* h 0.2))) (- py (* h 0.56)) 0.0)) ; 第二条线段右端点坐标
(setq lstp(list p1 p2 p3 p4))
)
(defun text-line1 (notifier-object reactor-object
parameter-list /
notifier-object reactor-object
parameter-list
)
(setq line1 (handent (vlr-data reactor-object)))
(setq text (vlax-vla-object->ename notifier-object)
textent (entget text)
)
(setq line1ent (entget line1)
line1ent (subst (cons 10 (car (getp1~4 textent)))
(assoc 10 line1ent)
line1ent
)
line1ent (subst (cons 10 (cadr (getp1~4 textent)))
(assoc 10 (reverse line1ent))
line1ent
)
)
(entmod line1ent)
(entupd line1)
)
(defun text-line2 (notifier-object reactor-object
parameter-list /
notifier-object reactor-object
parameter-list
)
(setq line2 (handent (vlr-data reactor-object)))
(setq text (vlax-vla-object->ename notifier-object)
textent (entget text)
)
(setq line2ent (entget line2)
line2ent (subst (cons 10 (caddr (getp1~4 textent)))
(assoc 10 line2ent)
line2ent
)
line2ent (subst (cons 11 (last (getp1~4 textent)))
(assoc 11 line2ent)
line2ent
)
)
(entmod line2ent)
(entupd line2)
)
(defun c:Tmx (/ box ent ent1 h nent1 nent2 np1 np2 np3 np4 old_lay p p1x p1y p2x p2y px py r snap test CH1 RLT)
(princ"\n.............图名线(命令tmx).............")
(vla-startUndoMark mydoc) ; 设置undo起点
(setq snap (getvar "osmode"))
(setq old_lay (getvar "clayer")) ; 保存当前图层
(setq old_col (getvar "cecolor"))
(setvar "osmode" 0) ; 关闭捕捉
(setvar "cmdecho" 0) ; 关闭命令响应
(SETVAR "Cecolor" "3")
(while
(setq ent1 (car (clh-entsel"\n选择文本：""" '((0 . "*TEXT"))"\n所选对像非文本,请重新选择...")))
(setq ent (entget ent1))
(if (= "MTEXT" (cdr (assoc 0 ent))); 如选多行文本，则转化为单行文本
(progn
(vl-cmdf "_.EXPLODE" ent1)
(setq ent1 (entlast) ent(entget ent1))
)
)
; 下面程序计算划线的起终点坐标。如需修改只需调整0.2、0.3、0.56三个参数
(setqnp1(car(getp1~4 ent)); 第一条线段左端点坐标。(* h 0.2)指水平方向距离文本基点0.2倍文本高度，(* h 0.3)竖直方向距0.3倍字高。
np2(cadr(getp1~4 ent)); 第一条线段右端点坐标
np3(caddr(getp1~4 ent)); 第二条线段左端点坐标
np4(last(getp1~4 ent)); 第二条线段右端点坐标
)
; 第一条下划线。(/ h 10)指第一条下划线宽度为文本高度的0.1倍，如需调整下划线宽度可以调整10的数值。
(entmake (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline")
(cons 90 2)(cons 43 (/ (cdr (assoc 40 ent)) 10)) (cons 10 np1) (cons 10 np2))
)
(setq nent1 (entlast))
(SETQ CH1(CDR(ASSOC 5(ENTGET NENT1))))
(entmake (list '(0 . "LINE") (cons 10 np3) (cons 11 np4))); 第二条下划线
(setq nent2 (entlast))
(SETQ CH2(CDR(ASSOC 5(ENTGET NENT2))))
(SETQ RLT(CONS(VLAX-ENAME->VLA-OBJECT ent1) '()))
(SETQ VRL1(VLR-PERS(VLR-OBJECT-REACTOR RLTCH1 '((:VLR-MODIFIED . TEXT-LINE1)))))
(SETQ VRL2(VLR-PERS(VLR-OBJECT-REACTOR RLTCH2 '((:VLR-MODIFIED . TEXT-LINE2)))))
)
(setvar "osmode" snap)
(setvar "clayer" old_lay) ; 恢复当前图层
(SETVAR "Cecolor" old_col)
(vla-endUndoMark mydoc)
(princ)
) 什么时候写的忘记了，在langjs基础上加了反应器，可能有问题，讲究用吧 (defun c:tmx (/ ent mspace i m wenzi a b c d aa bb cc dd ee ff gg leader)
(command "layer" "M" "文字" "C" "1" "" "LT" "CONTINUOUS" "" "");设置一个标注图层
(setq qz (getstring "\n请输入文字: "))
(setq ent (car (entsel)))
(setq mspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq i T)
(while i
(setq a (grread T 4 0) b (car a) c (cadr a))
(cond ((= b 5)
(setq a (trans (cadr a) 1 0))
(setq d (vlax-curve-getclosestpointto ent a))
(setq aa (car a) bb (cadr a) cc (caddr a))
(setq dd (car d) ee (cadr d) ff (caddr d)) ;;★创建引线★
(setq gg (vlax-make-safearray vlax-vbDouble '(0 . 5)))
(vlax-safearray-fill gg (list dd ee ff aa (- (cadr a) 2) cc))
(if (not Leader);;如果leader为空
(progn
(setq m (vla-AddMText mspace (vlax-3d-point (list aa (- (cadr a) 1.2))) 0 qz)) ;;创建文字A
(setq wenzi (vlax-make-safearray vlax-vbString '(1 . 9)))
(vlax-safearray-fill wenzi '("TopLeft" "TopCenter" "TopRight" "MiddleLeft"
"MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight"))
(setq Leader (vla-AddLeader mspace gg m acLineWithArrow))
) ;;end_progn
);;end_if
(if (<= aa dd) ;;
(vla-put-AttachmentPoint m 9)
(vla-put-AttachmentPoint m 7)
);;end_if
(vla-put-InsertionPoint m (vlax-3d-point (list aa (- (cadr a) 1.5))))
(vla-put-Coordinates Leader gg)
(vla-put-VerticalTextPosition Leader 1)
) ;;end_cond第一个括号
((= b 3) (setq i nil))
) ;;end_cond
) ;;end_while
(c:tmx)
) 全好人啊 加前缀 %%U 能行吗？ yjr111 发表于 2015-3-29 02:16 static/image/common/back.gif
;;; =================================================================
;;; 文本加下划线
;;; ======= ...
大师，不能运行呀，加载后输入命令提示 ............图名线(命令tmx).............; 错误: 参数类型错误: VLA-OBJECT nil
香田里浪人 发表于 2015-3-29 09:07 static/image/common/back.gif
(defun c:tmx (/ ent mspace i m wenzi a b c d aa bb cc dd ee ff gg leader)
(command "layer" "M" "文字 ...
大师，能不能帮我改成不用选择物体，直接指定引线的第一点，第二点呢
页:
[1]