[Shoorup]

Задача такая:
Есть куча чертежей (как обычно ) в которых куча однострочных текстов содержащих от 6 до 12 символов. Выравнивание у них всегда либо "влево" либо "вправо". Коэффициент сжатия всегда при изменениях варьируется. Но стандартно он не превышает 0.8 В зависимости от того как расположена близ лежащая линия изменяется коэффициент сжатия (вручную - что утомительно методом подбора). Изменяется он ступенчато до двух знаков после запятой. (0.8; 0.79; 0.78 ... 0.45)
Необходимо написать програмку которая будет это делать автоматически.
Т.е. например у меня есть горизонтальная линия справа от нее написан текст который либо слишком сжат либо переваливает через линию. Выбираем линию и потом тексты. При выборе очередного текста он автоматом изменяет коэффициент сжатия на необходимый.

[Shoorup]

Donhuan, спасибо. Буду штудировать.

[Кулик Алексей aka kpblc]

Учиться мне сейчас что-то лениво, поэтому один из вариантов кода:

Код:

[Выделить все]

(defun test (adds              /                 fun_get-length-by-angle
             text              plines            adoc
             *error*           _dwgru-conv-pickset-to-list
             min_dist          text_box          err
             )

            ;|
*    adds -> "ширина" дополнительных пропусков спереди и сзади текста.
*    Проверок минимум
*    Пример вызова:
(test 0.)
(test 1.5)
*    Точка вставки и выравнивание текста не меняется и не анализируется.
|;

  (defun _dwgru-conv-pickset-to-list (value / tab item)
    (repeat (setq tab  nil
                  item (sslength value)
                  ) ;_ end setq
      (setq tab (cons (ssname value (setq item (1- item))) tab))
      ) ;_ end repeat
    ) ;_ end defun

  (defun *error* (msg)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (defun fun_get-length-by-angle (ent ang / coord res counter)
    (setq ent     (entget ent)
          coord   (mapcar 'cdr
                          (vl-remove-if-not '(lambda (x) (= (car x) 10)) ent)
                          ) ;_ end of mapcar
          ang     (cos ang)
          counter 0
          ) ;_ end of setq
    (if (= (logand (cdr (assoc 70 ent)) 1) 1)
      (setq coord (append coord (list (car coord))))
      ) ;_ end of if
    (repeat (1- (length coord))
      (if (or (equal (cos (angle (nth counter coord) (nth (1+ counter) coord)))
                     ang
                     1e-6
                     ) ;_ end of equal
              (equal (cos (angle (nth (1+ counter) coord) (nth counter coord)))
                     ang
                     1e-6
                     ) ;_ end of equal
              ) ;_ end of or
        (setq
          res
           (cons (distance (nth counter coord) (nth (1+ counter) coord)) res)
          ) ;_ end of setq
        ) ;_ end of if
      (setq counter (1+ counter))
      ) ;_ end of repeat
    (reverse res)
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (if (and (setq text ((lambda ()
                         (prompt "\nВыбирай тексты : ")
                         (ssget "_:L" '((0 . "*TEXT")))
                         ) ;_ end of lambda
                       )
                 ) ;_ end of setq
           (setq plines
                  (cond
                    (((lambda ()
                        (prompt "\nВыбери как минимум одну полилинию : ")
                        (ssget '((0 . "LWPOLYLINE")))
                        ) ;_ end of lambda
                      )
                     )
                    (t
                     (getdist
                       (strcat
                         "\nУкажи расстояние, в которое надо вписывать, включая отступ в "
                         (rtos adds)
                         " ед. : "
                         ) ;_ end of strcat
                       ) ;_ end of getdist
                     )
                    ) ;_ end of cond
                 ) ;_ end of setq
           ) ;_ end of and
    (progn
      (setq min_dist
             (cond
               ((= (type plines) 'pickset)
                (- (apply 'min
                          (apply 'append
                                 (mapcar '(lambda (x) (fun_get-length-by-angle x 0.))
                                         (_dwgru-conv-pickset-to-list plines)
                                         ) ;_ end of mapcar
                                 ) ;_ end of apply
                          ) ;_ end of apply
                   adds
                   ) ;_ end of -
                )
               (t (- plines adds))
               ) ;_ end of cond
            ) ;_ end of setq
      (foreach item (_dwgru-conv-pickset-to-list text)
        (if (vl-catch-all-error-p
              (setq err
                     (vl-catch-all-apply
                       (function
                         (lambda (/ real_dist)
                           (vla-put-scalefactor (vlax-ename->vla-object item) 1.)
                           (if
                             (>= (setq
                                   real_dist
                                    (abs (apply
                                           '-
                                           (mapcar 'car (textbox (entget item)))
                                           ) ;_ end of apply
                                         ) ;_ end of abs
                                   ) ;_ end of setq
                                 min_dist
                                 ) ;_ end of >=
                              (vla-put-scalefactor
                                (vlax-ename->vla-object item)
                                (/ min_dist real_dist)
                                ) ;_ end of vla-put-scalefactor
                              ) ;_ end of if
                           ) ;_ end of lambda
                         ) ;_ end of function
                       ) ;_ end of vl-catch-all-apply
                    ) ;_ end of setq
              ) ;_ end of vl-catch-all-error-p
          (princ (strcat "\n** error ** : " (vl-catch-all-error-message err)))
          ) ;_ end of if
        ) ;_ end of foreach
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

[Shoorup]

Кулик Алексей aka kpblc, чтото не очень понятно что эта прога делает Чтото похожее есть но сжимает текст ну очень сильно.
С вызовом очень не понятно.

[Кулик Алексей aka kpblc]

Я гонял на твоем файле. Видео, как я вызывал - в аттаче

[Shoorup]

Получилось! Супер! Спасбо Алексей огромное.

[Shoorup]

Алексей, если не сложно добавь еще чтобы можно было текст ровнять не только по полилинии, но и по просто линии.

[Кулик Алексей aka kpblc]

В коде найди строку

Код:

[Выделить все]

(ssget '((0 . "LWPOLYLINE")))

и замени на

Код:

[Выделить все]

(ssget '((0 . "LINE,LWPOLYLINE")))

У меня сейчас просто шансов нуль исправить по полной. По идее работать должно
P.S. Кстати, если не укажешь никакой примитив, то можно будет просто указывать расстояние Попробуй, может, такой вариант окажется более удобным?
P.P.S. Если указывать несколько примитивов, то будет выбираться минимальная длина горизонтального участка.
---
Добавлено: только что "дошло". Работать не будет предложенное исправление. Придется погодить

[Кулик Алексей aka kpblc]

Как вариант - см.аттач.

[Shoorup]

(compress-text 0.)
(compress-text 1.5)
Не могу догнать как работает это? Что означает сие цыфры? Да и вообще принцип работы программы не очень понимаю. Алексей если не сложно объясни.

[Кулик Алексей aka kpblc]

Ну а что там объяснять? Если, например, текст вписывается в прямоугольник с координатами по оси Х 10 - 50 (то есть "длина" текста 40), а отрезок имеет длину по той же оси 16, то тексту назначается коэффициент сжатия (при compress-text 1.5):
Там просто аналитики многовато (возможно, лишней)

[allar8]

У меня АСАД 2010. Есть блоки с многострочными атрибутами. Для них почему то не активно редактирование коэффициента растяжения
(редактор атрибутов блоков -> Параметры текста -> Степень растяжения - Не активна). Можно как нибудь решить эту проблему?

[Do$]

Может быть это от шрифта зависит? С этим шрифтом обычный мультитекст сжимается?

[Олег (jr.)]

Сообщение от allar8 У меня АСАД 2010. Есть блоки с многострочными атрибутами. Для них почему то не активно редактирование коэффициента растяжения (редактор атрибутов блоков -> Параметры текста -> Степень растяжения - Не активна). Можно как нибудь решить эту проблему?

Попробуй так

Код:

[Выделить все]

(defun C:demo(/ attObj en scl)
  (vl-load-com)
(if
(and(setq en (nentsel "\nSelect Attribute: "))
    (setq scl (getreal "\nScale Factor: ")))
(progn
(setq attObj (vlax-ename->vla-object(car en)))
(if ;|check if selected is multiline attribute|;
  (eq :vlax-true (vla-get-mtextattribute attObj))
  (progn
  (vla-put-mtextboundarywidth attObj scl)
  (vla-put-scalefactor attObj scl)
  
;;;possible values are: 
;;;acLeftToRight - 1 	
;;;acRightToLeft - 2 	
;;;acTopToBottom - 3	
;;;acBottomToTop - 4 	
;;;acByStyle - 5	
  
  (vla-put-mtextdrawingdirection attObj
    (vla-get-mtextdrawingdirection attObj));<-- would not work in ObjectDBX application  ! 
  (vla-updatemtextattribute attobj))
  (progn ;|single text attribute|;
    (vla-put-scalefactor attObj scl)
    (vla-update attobj)
    )
  )
)
)(princ))

[Эдуард]

Вы пытаетесь заново написать команду Textfit ?

[Олег (jr.)]

Сообщение от Эдуард Вы пытаетесь заново написать команду Textfit ?

Ба, кого я вижу, ES, большой привет!
Это мне ?

[Эдуард]

Привет. Я написал всем участникам темы. Автору нужно (имхо) уйти от подбора вручную коэффициента сжатия текста , что успешно и выполняет команда Textfit.

[Олег (jr.)]

@Эдуард,
Рад что ты снова в строю,
Удачи и успехов,
Many regards

[allar8]

Сообщение от allar8 У меня АСАД 2010. Есть блоки с многострочными атрибутами. Для них почему то не активно редактирование коэффициента растяжения (редактор атрибутов блоков -> Параметры текста -> Степень растяжения - Не активна). Можно как нибудь решить эту проблему?

Я нашел ответ. Системная переменная ATTIPE