社区 › AutoLISP/Visual LISP 编程技术 › 单行文本动态拉伸

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

尘缘一生 发表于 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)
)

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

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

查看完整版本: 单行文本动态拉伸