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

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

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

)
                            .
                              .

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

好程序、

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

谢谢大神的分享

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

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

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

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


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

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

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

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

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

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

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

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

Maxwell 发表于 2024-6-19 18:59:31

本帖最后由 Maxwell 于 2024-6-19 19:03 编辑

lee50310 发表于 2023-6-18 06:19
圈選 多組文字
無法同步縮放
只能 一個文字縮放完 在換下一個文字
怪不得呢，框选多个无效

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