Лисп нормализации высот текстов в чертеже.

Привет всем.

Лисп нормализации высот текстов в чертеже с dwg.ru кратно некоторому размеру base:

Код:

(defun c:AdjustTextHeight (/ ss i j ent textHeight neatHeight newHeight base) 
  (setq base (getdist "\nBase: ")) 
  (if (> base 0) 
    (progn 
      (setq ss (ssget "_X" '((0 . "TEXT,MTEXT")))) ; get all text objects 
      (if ss 
        (progn 
          (setq i 0) 
          (setq j 0) 
          (while (< i (sslength ss)) 
            (setq ent (ssname ss i)) ; get text object 
            (setq textHeight (cdr (assoc 40 (entget ent)))) ; current Height 
             
            ;; Calc neat and new Height 
            (setq neatHeight (* base (fix (+ 0.5 (/ textHeight base))))) 
            (setq newHeight (if (> neatHeight 0) neatHeight base)) 
             
            ;; Apply new Height 
            (if (/= textHeight newHeight) 
              (progn 
                (entmod (subst (cons 40 newHeight) (assoc 40 (entget ent)) (entget ent))) 
                (entupd ent) 
                (setq j (1+ j)) 
              ) 
            ) 
             
            (setq i (1+ i)) 
          ) 
          (princ (strcat "\nUpdate " (itoa j) " text height.")) 
        ) 
        (princ "\nNot found text.") 
      ) 
    ) 
    (princ "\nBase incorrect.") 
  ) 
  (princ) 
)

Может кто-нибудь проверить работоспособность? (у меня сейчас нечем)

 

Работает. Но вот эта конструкция странная:

Код:

                  (setq newHeight (if (> neatHeight 0)
                                   neatHeight
                                   base
                                  )
                  )

По идее должно быть так:

Код:

                  (if (> neatHeight 0)
                   (setq newHeight neatHeight)
                   (setq newHeight base)
                  )

А, вообще эти строки не нужны, т.к. neatHeight не может быть меньше или равен 0.

 

хм, прикольно конечно, но почему не выбрать весь текст и назначить высоту в свойствах?

--- Сообщения объединены, 19 фев 2025, Оригинальное время сообщения: 19 фев 2025 ---

ну, в смысле Ctrl+A - быстрый выбор - текст - выбрать весь и меняешь

 

Проверь лисп на base, превышающем размер дюбого текста в 2 раза с этим условием и без него, пожалуйста.

Потому что ненужен один размер. Нужна линейка размеров, кратная base. Например, для base равного 0.1 линейка будет 0.1, 0.2, 0.3,...

 

Все работает и с условием и без условия.
Переработанный вариант:

Код:

(defun c:AdjustTextHeight (/ ss i j ent textHeight newHeight base)
 (setq base (getdist "\nBase: "))
 (if (> base 0)
  (progn (setq ss (ssget "_X" '((0 . "TEXT,MTEXT")))) ; get all text objects
         (if ss
          (progn (setq i 0)
                 (setq j 0)
                 (while (< i (sslength ss))
                  (setq ent (ssname ss i)) ; get text object
                  (setq textHeight (cdr (assoc 40 (entget ent)))) ; current Height
                  ;; Calc new Height
                  (setq newHeight (* base (fix (+ 0.5 (/ textHeight base)))))
                  (if (/= textHeight newHeight)
                   (progn (entmod (subst (cons 40 newHeight) (assoc 40 (entget ent)) (entget ent)))
                          (entupd ent)
                          (setq j (1+ j))
                   )
                  )
                  (setq i (1+ i))
                 )
                 (princ (strcat "\nUpdate " (itoa j) " text height."))
          )
          (princ "\nNot found text.")
         )
  )
  (princ "\nBase incorrect.")
 )
 (princ)
)