[Danil55]

Прошу помочь написать код на Lisp для уменьшения коэффициента сжатия текста внутри ячейки автокадовской таблицы.
Задача следующая:
Имеется таблица с ячейками определенной ширины. В некоторых ячейках таблицы имеется текст, который не входит в одну строку. Требуется уменьшить коэффициент сжатия текста в определенной ячейке так, чтобы текст был в одну строку. Как добраться до ячейки понятно (нашел на форме), понятно как перезаписать тот же текст с новым коэффициентом сжатия. Вопрос в автоматическом подборе необходимого значения коэффициента сжатия.

Пока Lisp у меня выглядит так

Код:

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

 
(defun C:WT ( / cellset)
(vl-load-com)
	(setq pt nil)
	(setq row nil)
	(setq col nil)
	(setq tblobj nil)
	(setq pt (getpoint "\n Укажите ячейку таблицы:"))
	(GET_CELL_ID pt)
	(vla-SetCellState tblobj row col acCellStateNone); разблокируем содержимое ячейки
  	(setq compres 0.5); для пробы новый коэффициент сжатия текста 0.5
     	(setq cellset (strcat "{\\W" (rtos compres) ";" (CELL_FIELD row col tblobj) "}")); получаем содержимое ячейки и устанавливаем новый коэффициент сжатия
	(vla-SetText tblobj row col cellset); записываем в ячейку строку
  	(vla-setrowheight tblobj row 8); устанавливаем высоту строки
 	(vla-SetCellState tblobj row col acCellStateContentLocked); блокируем содержимое ячейки
  ) ; end of defun

Функции GET_CELL_ID и CELL_FIELD взяты из темы https://forum.dwg.ru/showthread.php?t=150447

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

Как вариант - загоняешь мтекст в анонимный блок, проверяешь его ширину, ну а потом уже вычисление коэффициента сжатия - вопрос математики 1 класса. Другой вопрос, что крайне желательно еще и высоту шрифта менять, чтобы не получить текст с коэффициентом сжатия 0.0001 и высотой 275.

[kp+]

Если покопаться в DXF-внутренностях таблицы, можно раскопать анонимный блок с именем *Тххх, соответствующий текущему отображаемому виду таблицы. А во внутренностях этого блока можно найти Мтексты, соответствующие каждой ячейке - не просто текстовые строки, а именно объекты типа Мтекст, со всеми геометрическими характеристиками. Ну а дальше vla-getboundingbox для этого самого Мтекста, vla-GetCellExtents для ячейки и все заверте... вот только искать придется очень долго и нудно. Я копнул с помощью окна контрольных значений для таблицы из одной ячейки, что так действительно возможно.
А код разбора DXF писать, да так, чтобы достоверно ориентироваться в этих дебрях по адресу ячейки - к сожалению, ниасилил.

Можно еще "подорвать" копию таблицы, тогда нужный объект Мтекст сам выпадет из ячейки. Потом прибрать обломки...но кто-то может сказать, что это неспортивно, все равно что глушить рыбу динамитом вместо искусной ловли на удочку

[Danil55]

Сообщение от Кулик Алексей aka kpblc Как вариант - загоняешь мтекст в анонимный блок, проверяешь его ширину, ну а потом уже вычисление коэффициента сжатия - вопрос математики 1 класса. Другой вопрос, что крайне желательно еще и высоту шрифта менять, чтобы не получить текст с коэффициентом сжатия 0.0001 и высотой 275.

Спасибо за наводку, получилось решить данную задачу через временный блок.
Полученный Lisp решает мои задачи, дальше можно накручивать разного рода проверки, чистки чертежа после себя и пр.

Код:

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

 

(defun C:Cell_Text_Compres ( / pt row col tblobj text_cell width_col horz_cell adoc blk obj minp maxp compres cellset)
(vl-load-com)
	(setq pt nil)
	(setq row nil)
	(setq col nil)
	(setq tblobj nil)
  	(setq pt (cadr (entsel "Укажите текст в ячейке:")))
	(GET_CELL_ID pt)
	(vla-SetCellState tblobj row col acCellStateNone)
  	(setq text_cell (CELL_FIELD row col tblobj))
  	(setq width_col (vla-GetColumnWidth tblobj col))
  	(setq horz_cell (vla-get-HorzCellMargin tblobj))
  	;(setq text_style (vla-GetCellTextStyle tblobj row col))
  	(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  	(setq blk (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) "*U"))
    	(vla-addattribute blk 3.5 acattributemodenormal "Prompt" (vlax-3d-point '(0. 0. 0.)) "Tag" text_cell) 
  	(setq obj (vla-insertblock (vla-get-modelspace adoc) (vlax-3d-point (trans pt 1 0)) (vla-get-name blk) 1. 1. 1. 0.))
	(vla-GetBoundingBox obj 'minp 'maxp)
	(setq minp (vlax-safearray->list minp)
	      maxp (vlax-safearray->list maxp)
	)
  	(vla-Delete obj)
  	(setq compres (substr (rtos (/ (- width_col (* horz_cell 2)) (- (nth 0 maxp) (nth 0 minp))) 2 16) 1 5))
  	(setq cellset (strcat "{\\W" compres ";" text_cell "}"))
	(vla-SetText tblobj row col cellset)
  	(vla-setrowheight tblobj row 8)
 	(vla-SetCellState tblobj row col acCellStateContentLocked)
) ; end of defun