单行文本动态拉伸

尘缘一生 · 发表于 2018-4-25 10:16

本帖最后由尘缘一生于 2018-5-6 18:18 编辑

程序修改下：增加改后变色，增加垂直书写判断合理调节。

;;; -----------------------------------
;;; 单行文本动态拉伸 by：langjs
;;; -----修改：白领坛主------------------------------
(defun c:qq (/ box data ent gr h hb hh loop p ss w wb ang)
(defun emod (h w ent)
(entmod (subst
(cons h w)
(assoc h ent)
ent
)
)
)
(if (setq ss (ssget ":E:S" '((0 . "TEXT"))))
(progn
(setq ent (entget (ssname ss 0))
p (cdr (assoc 10 ent))
h (cdr (assoc 40 ent))
w (cdr (assoc 41 ent))
ang (cdr (assoc 50 ent))
box (textbox (cdr ent))
hb (/ (cadr (cadr box)) h)
wb (/ (car (cadr box)) (* h w))
loop t
)
(princ "\n指定拉伸点:")
(while loop
(setq gr (grread t 15 0)
data (cadr gr)
)
(cond
((= (car gr) 3)
(setq loop nil)
)
((= (car gr) 5)
(if (/= 1 (sin ang))
(progn
(setq hh (* hb (abs (- (cadr data) (cadr p))))
ent (emod 40 hh ent)
)
(emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
)
)
(if (= 1 (sin ang))
(progn
(setq hh (/ (* hb (abs (- (cadr data) (cadr p)))) 2)
ent (emod 40 hh ent)
)
(emod 41 (/ (abs (- (cadr data) (cadr p))) (* hh wb)) ent)
)
)
)
((member (car gr) '(11 25))
(setq loop nil
ent (emod 40 h ent)
)
(emod 41 w ent)
)
)
)
)
)
(setq oldlup (getvar "LUPREC"))
(setvar "LUPREC" 0) ; 精度到各位,以便后续取得标准颜色号
(command "CHANGE" (ssname ss 0) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS")
8
)
)
) ""
)
(setvar "LUPREC" oldlup) ; 恢复数值小数位数
(princ)
)

;;; ----------------------------------- 
;;; 单行文本动态拉伸 by：langjs 
;;; -----修改：白领坛主------------------------------ 
(defun c:qq (/ box data ent gr h hb hh loop p ss w wb ang) 
  (defun emod (h w ent) 
    (entmod (subst 
              (cons h w) 
              (assoc h ent) 
              ent 
            ) 
    ) 
  ) 
  (if (setq ss (ssget ":E:S" '((0 . "TEXT")))) 
    (progn 
      (setq ent (entget (ssname ss 0)) 
        p (cdr (assoc 10 ent)) 
        h (cdr (assoc 40 ent)) 
        w (cdr (assoc 41 ent)) 
        ang (cdr (assoc 50 ent)) 
        box (textbox (cdr ent)) 
        hb (/ (cadr (cadr box)) h) 
        wb (/ (car (cadr box)) (* h w)) 
        loop t 
      )    
      (princ "\n指定拉伸点:") 
      (while loop 
        (setq gr (grread t 15 0) 
          data (cadr gr) 
        ) 
        (cond 
          ((= (car gr) 3) 
            (setq loop nil) 
          ) 
          ((= (car gr) 5) 
            (if (/= 1 (sin ang)) 
              (progn 
                (setq hh (* hb (abs (- (cadr data) (cadr p)))) 
                  ent (emod 40 hh ent) 
                ) 
                (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent) 
              ) 
            ) 
            (if (= 1 (sin ang)) 
              (progn 
                (setq hh (/ (* hb (abs (- (cadr data) (cadr p)))) 2) 
                  ent (emod 40 hh ent) 
                ) 
                (emod 41 (/ (abs (- (cadr data) (cadr p))) (* hh wb)) ent) 
              ) 
            )             
          ) 
          ((member (car gr) '(11 25)) 
            (setq loop nil 
              ent (emod 40 h ent) 
            ) 
            (emod 41 w ent) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (setq oldlup (getvar "LUPREC")) 
  (setvar "LUPREC" 0)           ; 精度到各位,以便后续取得标准颜色号 
  (command "CHANGE" (ssname ss 0) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS") 
                                                         8 
                                                       ) 
                                                   ) 
                                             ) "" 
  ) 
  (setvar "LUPREC" oldlup)         ; 恢复数值小数位数 
  (princ) 
)

taoyi0727 · 发表于 2018-4-25 11:23

不错的楼主，谢谢分享啊。

qssq · 发表于 2019-11-14 11:32

请问怎样修改能固定字高，仅仅拉伸宽度?

yoyoho · 发表于 2019-11-15 11:56

不错的楼主，谢谢分享!!!!!

ketxu · 发表于 2020-1-5 10:01

本帖最后由 ketxu 于 2020-1-5 11:56 编辑

This not catch case (divide by zero)

zhaozwf · 发表于 2021-1-30 19:34

这个不错，谢谢分享

ninja37 · 发表于 2021-1-31 12:29

很好用啊省的每次放大缩小还大小控制不好不错的楼主

ninja37 · 发表于 2021-1-31 12:30

大师再放点干货出来啊

彳余 · 发表于 2021-6-19 09:07

大师，能否支持块内或者块属性文字?

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

[源码] 单行文本动态拉伸