单行文本动态拉伸

lee50310 · 发表于 2021-6-19 10:06

本帖最后由 lee50310 于 2023-6-18 05:55 编辑

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

修改後

;;; -----------------------------------
;;; 单行文本动态拉伸 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)))))
(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)
)
)
)
)
)
(princ)
)

;;; ----------------------------------- 
;;; 单行文本动态拉伸 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))))) 
     (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) 
    ) 
  ) 
      ) 
    ) 
  ) 
  (princ) 
 
)

.
.

paulpipi · 发表于 2021-6-20 21:17

好程序、

moranyuyan · 发表于 2022-9-7 16:12

谢谢大神的分享

戏男 · 发表于 2023-6-17 19:23

这个好像只能对一个文本起作用，可以框选几行文本统一放大缩小吗？把所选的所有文本当成一个整体来缩放

戏男 · 发表于 2023-6-17 19:28

lee50310 发表于 2021-6-19 10:06
找到程式中的程式碼 .
.
(cond

不能框选文字，只能单独处理一个文字

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

本帖最后由 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

edsion24 · 发表于 2023-6-19 08:02

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

jkop · 发表于 2023-11-29 18:48

方便使用，简单明了，收藏！

yefei812678 · 发表于 2024-3-22 09:57

感谢分享感谢分享感谢分享

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

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

本帖子中包含更多资源