文字齐线修改版

vectra · 发表于 2014-12-24 20:59:42

本帖最后由 vectra 于 2014-12-24 21:16 编辑

支持单行及多行文字，直线及多段线，仅修改文字角度，对位置不做处理。

修改自 wzg356 http://bbs.mjtd.com/thread-112540-1-1.html

借用他人代码，不参加悬赏，故另开一贴
做标注程序时很有用的代码，发在这里做个备份。

(defun c:tt (/ picksegendpt en1 en2 enl1 enl2 p1 p1p2 p2 p3)
(defun picksegendpt (obj p / n)
(setq p (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj p))
)
(list (vlax-curve-getpointatparam obj n)
(vlax-curve-getpointatparam obj (1+ n))
)
)
(while
(not
(and
(setq en1 (entsel "\n选择单行或多行文字："))
(wcmatch (cdr (assoc 0 (setq enl1 (entget (car en1)))))
"*TEXT"
)
)
)
)
(while
(not
(wcmatch
(cdr
(assoc 0
(setq
enl2 (entget
(car (setq en2 (entsel "\n选择要对齐的直线:")))
)
)
)
)
"*LINE"
)
)
)
(setq p3 (cadr en2))
(if (= (cdr (assoc 0 enl2)) "LINE")
(setq p1 (cdr (assoc 10 enl2))
p2 (cdr (assoc 11 enl2))
)
(setq p1p2 (picksegendpt (car en2) p3)
p1 (car p1p2)
p2 (cadr p1p2)
)
)
(if (<= (distance p3 p1) (distance p3 p2))
(setq enl1 (subst (cons 50 (angle p1 p2)) (assoc 50 enl1) enl1))
(setq enl1 (subst (cons 50 (angle p2 p1)) (assoc 50 enl1) enl1))
)
(entmod enl1)
(princ)
)

(defun c:tt (/ picksegendpt en1 en2 enl1 enl2 p1 p1p2 p2 p3) 
  (defun picksegendpt (obj p / n) 
    (setq p (vlax-curve-getclosestpointto obj (trans p 1 0)) 
    n (fix (vlax-curve-getparamatpoint obj p)) 
    ) 
    (list (vlax-curve-getpointatparam obj n) 
    (vlax-curve-getpointatparam obj (1+ n)) 
    ) 
  ) 
 
  (while 
    (not 
      (and 
  (setq en1 (entsel "\n选择单行或多行文字：")) 
  (wcmatch (cdr (assoc 0 (setq enl1 (entget (car en1))))) 
     "*TEXT" 
  ) 
      ) 
    ) 
  ) 
  (while 
    (not 
      (wcmatch 
  (cdr 
    (assoc 0 
     (setq 
       enl2  (entget 
        (car (setq en2 (entsel "\n选择要对齐的直线:"))) 
      ) 
     ) 
    ) 
  ) 
  "*LINE" 
      ) 
    ) 
  ) 
 
  (setq p3 (cadr en2)) 
 
  (if (= (cdr (assoc 0 enl2)) "LINE") 
    (setq p1 (cdr (assoc 10 enl2)) 
    p2 (cdr (assoc 11 enl2)) 
    ) 
    (setq p1p2 (picksegendpt (car en2) p3) 
    p1   (car p1p2) 
    p2   (cadr p1p2) 
    ) 
  ) 
 
  (if (<= (distance p3 p1) (distance p3 p2)) 
    (setq enl1 (subst (cons 50 (angle p1 p2)) (assoc 50 enl1) enl1)) 
    (setq enl1 (subst (cons 50 (angle p2 p1)) (assoc 50 enl1) enl1)) 
  ) 
  (entmod enl1) 
  (princ) 
)

newbuser · 发表于 2014-12-26 10:06:39

xiaobaixiaobu 发表于 2014-12-25 10:02
要是能做到这样就好了！！

;; 通用grread定义
(defun ZML-GRREAD (LST / TEST TMP MODE VAL TMP2)
(setq TEST t)
(while TEST
(setq TMP (grread 2)
MODE (car TMP)
VAL (cadr TMP)
)
(cond ((= MODE 2)
(if (and (setq TMP2 (assoc MODE LST))
(setq TMP2 (cdr TMP2))
(setq TMP2 (assoc VAL TMP2))
)
(eval (cons 'progn (cdr TMP2)))
()
)
)
((setq TMP2 (assoc MODE LST))
(eval (cons 'progn (cdr TMP2)))
)
(t (princ TMP))
)
)
)
;;;========================================================
;;;文字随线(角度随线的)
(vl-load-com)
(defun C:ts (/ tt-01 tt-02 LST)
;;===============
;;功能：计算计算距给定点位最近的线上点和线上点的前进方位角
;;参数：EN_LINE -----线的图元名称
;; PT -----给定点位
;;返回：距点最近的线上点和线上点的方位角
(defun TT-01 (EN_LINE PT / OBJ PT1 LST ANG)
;;将图元名转换为 VLA对象
(setq OBJ (vlax-ename->vla-object EN_LINE))
;;距pt最近的曲线上的点pt1
(setq PT1 (vlax-curve-getclosestpointto OBJ PT))
;;pt1点的切线方向矢量
(setq LST (vlax-curve-getfirstderiv
OBJ
(vlax-curve-getparamatpoint
OBJ
PT1
)
)
)
;;计算切线方位角
(setq ANG (atan (/ (cadr LST) (car LST))))
;;返回
(list PT1 ANG)
)
;;===============
;;功能：设置文字对象位置及角度
(defun TT-02 (EN_TEXT PT ANG / ENT)
(setq ENT (entget EN_TEXT))
(setq ENT (subst (cons 10 PT) (assoc 10 ENT) ENT)
ENT (subst (cons 11 PT) (assoc 11 ENT) ENT)
ENT (subst (cons 50 ANG) (assoc 50 ENT) ENT)
)
(entmod ENT)
)
;;===============
(if (and
;;
(setq SS (entsel "\n点取线: "))
(setq EN_LINE (car SS))
(setq ENT_LINE (entget EN_LINE))
(wcmatch (cdr (assoc 0 ENT_LINE))
"LINE,ARC,LWPOLYLINE,SPLINE"
)
;;
(setq SS (entsel "\n点取文字: "))
(setq EN_TEXT (car SS))
(setq ENT_TEXT (entget EN_TEXT))
(wcmatch (cdr (assoc 0 ENT_TEXT)) "TEXT,MTEXT")
)
(progn
(setq LST
(list '(5
;;
(setq
TMP
(TT-01 EN_LINE VAL)
PT1
(car TMP)
ANG
(cadr TMP)
)
;;
(TT-02 EN_TEXT VAL ANG)
(vlax-get-property (vlax-ename->vla-object EN_text) 'InsertionPoint )
;;
(redraw)
(grdraw VAL PT1 1)
)
;;左击
'
(3
(redraw)
(setq TEST NIL)
)
'(25
(redraw)
(setq TEST NIL)
)
'(11
(redraw)
(setq TEST NIL)
)
)
)
(ZML-GRREAD LST)
)
)
(princ)
)

;;  通用grread定义 
(defun ZML-GRREAD (LST / TEST TMP MODE VAL TMP2) 
    (setq TEST t) 
    (while TEST 
  (setq TMP  (grread 2) 
        MODE (car TMP) 
        VAL  (cadr TMP) 
  ) 
  (cond ((= MODE 2) 
         (if (and  (setq TMP2 (assoc MODE LST)) 
      (setq TMP2 (cdr TMP2)) 
      (setq TMP2 (assoc VAL TMP2)) 
       ) 
       (eval (cons 'progn (cdr TMP2))) 
       () 
         ) 
        ) 
        ((setq TMP2 (assoc MODE LST)) 
         (eval (cons 'progn (cdr TMP2))) 
        ) 
        (t (princ TMP)) 
  ) 
    ) 
) 
;;;======================================================== 
;;;文字随线(角度随线的) 
(vl-load-com) 
(defun C:ts (/ tt-01 tt-02 LST) 
    ;;=============== 
    ;;功能：计算计算距给定点位最近的线上点 和 线上点的前进方位角 
    ;;参数：EN_LINE -----线的图元名称 
    ;;           PT -----给定点位 
    ;;返回：距点最近的线上点 和 线上点的方位角 
    (defun TT-01 (EN_LINE PT / OBJ PT1 LST ANG) 
  ;;将图元名转换为 VLA对象 
  (setq OBJ (vlax-ename->vla-object EN_LINE)) 
  ;;距pt最近的曲线上的点pt1 
  (setq PT1 (vlax-curve-getclosestpointto OBJ PT)) 
  ;;pt1点的切线方向矢量 
  (setq LST (vlax-curve-getfirstderiv 
          OBJ 
          (vlax-curve-getparamatpoint 
        OBJ 
        PT1 
          ) 
      ) 
  ) 
  ;;计算切线方位角 
  (setq ANG (atan (/ (cadr LST) (car LST)))) 
  ;;返回 
  (list PT1 ANG) 
    ) 
    ;;=============== 
    ;;功能：设置文字对象位置及角度 
    (defun TT-02 (EN_TEXT PT ANG / ENT) 
  (setq ENT (entget EN_TEXT)) 
  (setq ENT (subst (cons 10 PT) (assoc 10 ENT) ENT) 
        ENT (subst (cons 11 PT) (assoc 11 ENT) ENT) 
        ENT (subst (cons 50 ANG) (assoc 50 ENT) ENT) 
  ) 
  (entmod ENT) 
 
    ) 
    ;;=============== 
    (if  (and 
      ;; 
      (setq SS (entsel "\n点取线: ")) 
      (setq EN_LINE (car SS)) 
      (setq ENT_LINE (entget EN_LINE)) 
      (wcmatch (cdr (assoc 0 ENT_LINE)) 
         "LINE,ARC,LWPOLYLINE,SPLINE" 
      ) 
      ;; 
      (setq SS (entsel "\n点取文字: ")) 
      (setq EN_TEXT (car SS)) 
      (setq ENT_TEXT (entget EN_TEXT)) 
      (wcmatch (cdr (assoc 0 ENT_TEXT)) "TEXT,MTEXT") 
 
  ) 
  (progn 
      (setq LST 
         (list '(5 
           ;; 
           (setq 
            TMP 
            (TT-01 EN_LINE VAL) 
            PT1 
            (car TMP) 
            ANG 
            (cadr TMP) 
           ) 
           ;; 
           (TT-02 EN_TEXT VAL ANG) 
             (vlax-get-property (vlax-ename->vla-object EN_text) 'InsertionPoint ) 
           ;; 
           (redraw) 
           (grdraw VAL PT1 1) 
          ) 
         ;;左击 
         ' 
          (3 
           (redraw) 
           (setq TEST NIL) 
          ) 
         '(25 
           (redraw) 
           (setq TEST NIL) 
          ) 
         '(11 
           (redraw) 
           (setq TEST NIL) 
          ) 
         ) 
      ) 
      (ZML-GRREAD LST) 
  ) 
    ) 
    (princ) 
)

看看这组代码是不是阁下想要的结果。

spp_wall · 发表于 2014-12-25 08:20:02

只对直线有效么？

USER2128 · 发表于 2014-12-25 08:28:33

代码简洁易懂，十分感谢楼主

enn09 · 发表于 2014-12-25 09:55:27

十分感谢楼主分享，多段线也能用~~

xiaobaixiaobu · 发表于 2014-12-25 10:02:28

要是能做到这样就好了！！

唐伯虎9527 · 发表于 2017-11-16 15:27:34

不错，支持一下。

NEWMEN · 发表于 2018-1-16 12:45:15

这个很不错，感谢分享

LIULISHENG · 发表于 2018-2-6 08:42:33

jhzxj · 发表于 2021-11-28 21:16:53

newbuser 发表于 2014-12-26 10:06
看看这组代码是不是阁下想要的结果。

目前我用过最好的文字齐线插件，谢谢，非常感谢，收藏。

账号		自动登录	找回密码
密码			注册

[源码] 文字齐线修改版

本帖子中包含更多资源

评分

本帖被以下淘专辑推荐:

本帖子中包含更多资源

点评

本帖子中包含更多资源