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



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

网友答: 本帖最后由 lee50310 于 2023-6-18 06:22 编辑
戏男 发表于 2023-6-17 19:28
不能框选文字，只能单独处理一个文字

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

  1. ;;; -----------------------------------
  2. ;;; 多组单行文本动态拉伸 by：langjs
  3. ;;  
  4. ;;; -----------------------------------

  6. (defun C:qq2 (/ box data ent gr h hb hh loop p ss w wb)
  7. ;---------------------------------------
  8.   (defun emod (v w ent)
  9.     (entmod (subst (cons v w) (assoc v ent) ent))
  10.   )
  11. ;---------------------------------------  
  12. (defun get-tt(ent)      
  13.   (setq p         (cdr (assoc 10 ent))
  14.             h         (cdr (assoc 40 ent))
  15.             w         (cdr (assoc 41 ent))
  16.             box         (textbox (cdr ent))
  17.             hb         (/ h (cadr (cadr box)))
  18.             wb         (/ (car (cadr box)) (* h w))
  19.             loop t
  20.   );end_setq
  21. )  
  22. ;----------------------------------------
  23.   
  24.   (if (setq ss (ssget '((0 . "TEXT"))))
  25.     (progn
  26.                        
  27.           (princ "\n指定拉伸点:")
  28.                   (foreach ex lst
  29.                     (setq ent(entget ex))
  30.                              (get-tt ent)
  31.       (while loop
  32.                  (setq gr   (grread t 15 0)
  33.                        data (cadr gr)
  34.                  );end_setq
  35.                  
  36.                                    
  37.                                         (cond
  38.                                                    ((= (car gr) 3)(setq loop nil))
  39.                                                  ((= (car gr) 5)
  40.                                          (setq hh(* hb (abs (- (cadr data) (cadr p)))))
  41.                                  (if (<= hh 0)(setq hh 0.1)) ;预防分母为0
  42.                                  (setq ent (emod 40 hh ent))
  43.                                  (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
  44.                              )
  45.                              ((member (car gr) '(11 25))           
  46.                                       (setq loop nil ent (emod 40 h ent))           
  47.                                       (emod 41 w ent)
  48.                              )
  49.             );end_cond
  50.                     
  51.       );end_while
  52.            );end_foreach
  53.     );end_progn
  54.   );end_if
  55.   (princ)
  56. );end_defun_qq



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

程序修改下：增加改后变色，增加垂直书写判断合理调节。
  1. ;;; -----------------------------------
  2. ;;; 单行文本动态拉伸 by：langjs
  3. ;;; -----修改：白领坛主------------------------------
  4. (defun c:qq (/ box data ent gr h hb hh loop p ss w wb ang)
  5.   (defun emod (h w ent)
  6.     (entmod (subst
  7.               (cons h w)
  8.               (assoc h ent)
  9.               ent
  10.             )
  11.     )
  12.   )
  13.   (if (setq ss (ssget ":E:S" '((0 . "TEXT"))))
  14.     (progn
  15.       (setq ent (entget (ssname ss 0))
  16.         p (cdr (assoc 10 ent))
  17.         h (cdr (assoc 40 ent))
  18.         w (cdr (assoc 41 ent))
  19.         ang (cdr (assoc 50 ent))
  20.         box (textbox (cdr ent))
  21.         hb (/ (cadr (cadr box)) h)
  22.         wb (/ (car (cadr box)) (* h w))
  23.         loop t
  24.       )   
  25.       (princ "\n指定拉伸点:")
  26.       (while loop
  27.         (setq gr (grread t 15 0)
  28.           data (cadr gr)
  29.         )
  30.         (cond
  31.           ((= (car gr) 3)
  32.             (setq loop nil)
  33.           )
  34.           ((= (car gr) 5)
  35.             (if (/= 1 (sin ang))
  36.               (progn
  37.                 (setq hh (* hb (abs (- (cadr data) (cadr p))))
  38.                   ent (emod 40 hh ent)
  39.                 )
  40.                 (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
  41.               )
  42.             )
  43.             (if (= 1 (sin ang))
  44.               (progn
  45.                 (setq hh (/ (* hb (abs (- (cadr data) (cadr p)))) 2)
  46.                   ent (emod 40 hh ent)
  47.                 )
  48.                 (emod 41 (/ (abs (- (cadr data) (cadr p))) (* hh wb)) ent)
  49.               )
  50.             )            
  51.           )
  52.           ((member (car gr) '(11 25))
  53.             (setq loop nil
  54.               ent (emod 40 h ent)
  55.             )
  56.             (emod 41 w ent)
  57.           )
  58.         )
  59.       )
  60.     )
  61.   )
  62.   (setq oldlup (getvar "LUPREC"))
  63.   (setvar "LUPREC" 0)           ; 精度到各位,以便后续取得标准颜色号
  64.   (command "CHANGE" (ssname ss 0) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS")
  65.                                                          8
  66.                                                        )
  67.                                                    )
  68.                                              ) ""
  69.   )
  70.   (setvar "LUPREC" oldlup)         ; 恢复数值小数位数
  71.   (princ)
  72. )


网友答: 大师的思路和技巧是值得学习的！

网友答: 进来好好学习，感谢大师分享源码

网友答: 这个有用，支持支持

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

网友答: 版本的作品，必须顶

网友答: 谢谢大师的分享。。

网友答:
感谢大师的分享。。

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

网友答: 不错的楼主，谢谢分享啊。
  • 上一篇：二维直线弧等分插入N个顶点并保持±凸度值附加
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025