单行文本动态拉伸

langjs · 发表于 2017-10-19 19:29:05

本帖最后由 langjs 于 2017-10-20 11:18 编辑

;;; -----------------------------------
;;; 单行文本动态拉伸 by：langjs
;;; -----------------------------------
(defun C:qq (/ box data ent gr h hb hh loop p ss w wb)
(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)) box (textbox (cdr ent)) hb (/ h (cadr (cadr box)))
  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) (setq hh (* hb (abs (- (cadr data) (cadr p)))) ent (emod 40 hh ent))
  (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent))
  ((member (car gr) '(11 25)) (setq loop nil ent (emod 40 h ent)) (emod 41 w ent)
  )))))
(princ)
)

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

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

lee50310 · 发表于 2023-6-18 06:19:23

本帖最后由 lee50310 于 2023-6-18 06:22 编辑

戏男发表于 2023-6-17 19:28
不能框选文字，只能单独处理一个文字

圈選多組文字
無法同步縮放
只能一個文字縮放完在換下一個文字

;;; -----------------------------------
;;; 多组单行文本动态拉伸 by：langjs
;;
;;; -----------------------------------
(defun C:qq2 (/ box data ent gr h hb hh loop p ss w wb)
;---------------------------------------
(defun emod (v w ent)
(entmod (subst (cons v w) (assoc v ent) ent))
)
;---------------------------------------
(defun get-tt(ent)
(setq p (cdr (assoc 10 ent))
h (cdr (assoc 40 ent))
w (cdr (assoc 41 ent))
box (textbox (cdr ent))
hb (/ h (cadr (cadr box)))
wb (/ (car (cadr box)) (* h w))
loop t
);end_setq
)
;----------------------------------------
(if (setq ss (ssget '((0 . "TEXT"))))
(progn
(princ "\n指定拉伸点:")
(foreach ex lst
(setq ent(entget ex))
(get-tt ent)
(while loop
(setq gr (grread t 15 0)
data (cadr gr)
);end_setq
(cond
((= (car gr) 3)(setq loop nil))
((= (car gr) 5)
(setq hh(* hb (abs (- (cadr data) (cadr p)))))
(if (<= hh 0)(setq hh 0.1)) ;预防分母为0
(setq ent (emod 40 hh ent))
(emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
)
((member (car gr) '(11 25))
(setq loop nil ent (emod 40 h ent))
(emod 41 w ent)
)
);end_cond
);end_while
);end_foreach
);end_progn
);end_if
(princ)
);end_defun_qq

;;; ----------------------------------- 
;;; 多组单行文本动态拉伸 by：langjs 
;;   
;;; ----------------------------------- 
 
(defun C:qq2 (/ box data ent gr h hb hh loop p ss w wb) 
;--------------------------------------- 
  (defun emod (v w ent) 
    (entmod (subst (cons v w) (assoc v ent) ent)) 
  ) 
;---------------------------------------   
(defun get-tt(ent)       
  (setq p         (cdr (assoc 10 ent)) 
            h         (cdr (assoc 40 ent)) 
            w         (cdr (assoc 41 ent)) 
            box         (textbox (cdr ent)) 
            hb         (/ h (cadr (cadr box))) 
            wb         (/ (car (cadr box)) (* h w)) 
            loop t 
  );end_setq 
)   
;---------------------------------------- 
   
  (if (setq ss (ssget '((0 . "TEXT")))) 
    (progn 
                        
          (princ "\n指定拉伸点:") 
                  (foreach ex lst 
                    (setq ent(entget ex)) 
                             (get-tt ent) 
      (while loop 
                 (setq gr   (grread t 15 0) 
                       data (cadr gr) 
                 );end_setq 
                  
                                    
                                        (cond 
                                                   ((= (car gr) 3)(setq loop nil)) 
                                                 ((= (car gr) 5) 
                                         (setq hh(* hb (abs (- (cadr data) (cadr p))))) 
                                 (if (<= hh 0)(setq hh 0.1)) ;预防分母为0 
                                 (setq ent (emod 40 hh ent)) 
                                 (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent) 
                             ) 
                             ((member (car gr) '(11 25))            
                                      (setq loop nil ent (emod 40 h ent))            
                                      (emod 41 w ent) 
                             ) 
            );end_cond 
                     
      );end_while 
           );end_foreach 
    );end_progn 
  );end_if 
  (princ) 
);end_defun_qq

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

本帖最后由尘缘一生于 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) 
)

shh1980 · 发表于 2017-10-20 09:14:08

大师的思路和技巧是值得学习的！

fsafaffa · 发表于 2017-10-20 12:14:18

进来好好学习，感谢大师分享源码

天下逍遥 · 发表于 2017-10-20 12:27:06

这个有用，支持支持

pengfei2010 · 发表于 2017-10-21 09:06:45

回帖是一种美德！感谢楼主的无私分享谢谢

逍遥天下 · 发表于 2017-10-21 10:48:31

版本的作品，必须顶

sdbaijiao · 发表于 2017-10-24 19:25:00

谢谢大师的分享。。

my258 · 发表于 2017-10-25 10:26:22

感谢大师的分享

。。

alexmai · 发表于 2017-10-27 19:17:05

很好用，以后不用这么麻烦的缩放字体了

vladimirputin · 发表于 2017-10-31 10:25:52

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

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

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

点评

评分