线上文字

小师傅

我想写一段文字，在文字下自动生成一条多段线，线段长度随文字长度，且文字与线段相关联，当修改或移动文字时，线段跟随变化。请大侠们出手相助！

yjr111

;;; =================================================================
;;; 文本加下划线
;;; =================================================================
(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三个参数
  (setq  np1  (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 RLT  CH1 '((:VLR-MODIFIED . TEXT-LINE1)))))
  (SETQ VRL2(VLR-PERS(VLR-OBJECT-REACTOR RLT  CH2 '((:VLR-MODIFIED . TEXT-LINE2)))))
  )
  (setvar "osmode" snap)
  (setvar "clayer" old_lay)               ; 恢复当前图层
  (SETVAR "Cecolor" old_col)
  (vla-endUndoMark mydoc)
  (princ)
)

yjr111

什么时候写的忘记了，在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)
)

davide888

全好人啊      

liu22737

加前缀 %%U 能行吗？

小师傅

yjr111 发表于 2015-3-29 02:16
;;; =================================================================
;;; 文本加下划线
;;; ======= ...

大师，不能运行呀，加载后输入命令提示    ............图名线(命令tmx).............; 错误: 参数类型错误: VLA-OBJECT nil

小师傅

香田里浪人 发表于 2015-3-29 09:07
(defun c:tmx (/ ent mspace i m wenzi a b c d aa bb cc dd ee ff gg leader)
(command "layer" "M" "文字 ...

大师，能不能帮我改成不用选择物体，直接指定引线的第一点，第二点呢