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

start4444 发表于 2017-11-29 17:18:22

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

taoyi0727 发表于 2018-4-25 11:23:45

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

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

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

yoyoho 发表于 2019-11-15 11:56:11

不错的楼主，谢谢分享!!!!!

ketxu 发表于 2020-1-5 10:01:24

本帖最后由 ketxu 于 2020-1-5 11:56 编辑

This not catch case(divide by zero)

zhaozwf 发表于 2021-1-30 19:34:48

这个不错，谢谢分享

ninja37 发表于 2021-1-31 12:29:46

很好用啊 省的每次放大缩小还大小控制不好不错的楼主

ninja37 发表于 2021-1-31 12:30:18

大师再放点干货出来啊

彳余 发表于 2021-6-19 09:07:47

大师，能否支持块内或者块属性文字?

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