[megabeton]

Есть лисп (во вложении), рисующий возле каждого отрезка (после выбора группы отрезков) текст с указанием его длины.
Однако хотелось бы его доработать, а именно:
- текст возле отрезка отрисовывается в текущем слое, а хотелось бы, что бы слой текста соответствовал слою отрезка;
- выравнивание отрисовываемого текста производилось "вниз по центру"
- добавить возможность работы с полилиниями и прочими примитивами (окружности, дуги и т.д.)
- добавить возможность установки поправочного коэффициента;
- добавить возможность установки необходимого округления/точности;
- добавить возможность установки высоты текста;
- ну и бонусом, сделать лисп со всем вышеперечисленным для возможности работы с площадями, т.е подписывать объекты, имеющие площадь

В принципе все вышеперечисленное умеет делать спецкалькулятор VetCAD, за одним исключением - он дает результат одним числом для всех выбранных отрезков/площадей, а нужна возможность подписать именно каждый примитив/площадь в группе за одно действие.

Прошу помощи знатоков лисп программирования!

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

А в каких строках у тебя проблемы? Посмотри DXF Reference - там много интересного. Или ты ошибся с разделом, и тебе в "Поиск исполнителей"?

[megabeton]

Да, мне в поиск исполнителей...

[trir]

усё готово

[Krieger]

Пользуюсь вот таким, несколько кустарно, но работает. Команда lal. На слой не заморачивался, т.к. у меня реактор стоит на текст.

Код:

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

;пишет длину всех выбранных отрезков
(defun c:lal (/ p1 p2 pt1 pt2 ent pr l)
(if (setq ss (ssget '((0 . "LINE"))))
  (progn
    (setq index -1
	    lr 0)
    (repeat (sslength ss)
      (setq index (1+ index)
	    pr (entget (ssname ss index))
	    pt1 (cdr (assoc 10 pr))
	    pt2 (cdr (assoc 11 pr))
	    L (Kr_roundof  (distance pt1 pt2) 1))
(vl-cmdf "_text" "0,0,0"
	 ;(* 2.5 (Kr_Scale nil))
	 "0" (rtos L 2 0))
(if (< (angtof "90") (angle pt1 pt2) (angtof "270.01" )) (setq p1 pt2 p2 pt1) (setq p1 pt1 p2 pt2))      
(Kr-AligmentText (* 1 (Kr_ScaleOfVP)) "ang" 0 p1 p2 (vlax-ename->vla-object (entlast)))
      );repeat
  );rogn
  );if
  );defun

;|Функция Kr_roundof
Округление числа с заданным множителем.
num - число для округления (вводить вещественное число)
presc - множитель

Примеры
(Kr_roundof 45985. 3) 45984.0 
(Kr_roundof -45.56 3) -45.0 
(Kr_roundof 459. 5) 460.0
(Kr_roundof 459 5) 455.0 
(Kr_roundof 4.3 1.2) 4.8
(Kr_roundof 0.1 1.2) 0.0
|;
(defun Kr_roundof (num presc / )
(* (atof (rtos (/ num presc) 2 0)) presc)
  )

;|
Функция Kr_AligmentTextLine
*** Автор Морозов С.В. aka Krieger ***
Выравнивает Mtext и Text относительно двух точек
Параметры
а - величина смещения текста над линией
An - угол в градусах или "ang" - угол по линии
Justify - выравнивание текста для Mtext/Text:
	0 - BottomCenter
	1 - MiddleCenter
	2 - TopCenter
Примеры:
(Kr_AligmentTextLine (* 2 (Kr_ScaleOfVP)) "ang" 0) ;над линией
(Kr_AligmentTextLine 0 0 1) ;просто в центр
(Kr_AligmentTextLine (* -2 (Kr_ScaleOfVP)) "ang" 2) ;под линию
(Kr_AligmentTextLine 0 30 1) ;в центр, с фиксированным углом 30 градусов
|;

(defun Kr-AligmentText (a An Justify p1 p2 vl-ent / UL UL2 pt2 An2)
	    	(setq 	UL1 (angle P1 P2)
			p1 (trans p1 1 0)
			p2 (trans p2 1 0)
			UL2 (angle P1 P2)
			pt2 (polar (polar P1 (angle P1 P2) (/ (distance P1 P2) 2))
				   (+ (* (/ 90.0 180.0) pi)
				      (angle p1 p2))
				   a))
	      
		(cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbMText");если Mtext
			(cond
			  ((= Justify 0) (vla-put-AttachmentPoint  vl-ent acAttachmentPointBottomCenter))
			  ((= Justify 1) (vla-put-AttachmentPoint  vl-ent acAttachmentPointMiddleCenter))
			  ((= Justify 2) (vla-put-AttachmentPoint  vl-ent acAttachmentPointTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (* (/ An 180.0) pi))
		  (setq An2 UL1))
		   
		   (vla-put-InsertionPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbText");если Text
			(cond
			  ((= Justify 0) (vla-put-Alignment vl-ent acAlignmentBottomCenter))
			  ((= Justify 1) (vla-put-Alignment vl-ent acAlignmentMiddleCenter))
			  ((= Justify 2) (vla-put-Alignment vl-ent acAlignmentTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (+ (* (/ An 180.0) pi) (- UL2 UL1)))
		  (setq An2 UL2))
		   
		   (vla-put-TextAlignmentPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );
		  );cond
  );defun



;|---------------------------------------------------------------
Функция Kr_ScaleOfVP
-----------------------------------------------------------------
Вычисляет масштаб в зависимоти от переменной dimscale или CANNOSCALEVALUE, если dimscale=0 коэф-т = 1 или относительно vport
|;
(defun Kr_ScaleOfVP ( / )
  ;если текущим установлен аннотативный размерный стиль, масштаб берем с аннотативного масштаба
  (if (= (getvar "dimanno") 1)
    (setq dsc (/ 1 (getvar "CANNOSCALEVALUE")))
    (progn
  ;если dimscale=0 принимаем dsc=1, если нет dsc=dimscale
  			(if (= (getvar "dimscale") 0) (setq dsc 1) (setq dsc (getvar "dimscale")))
  ;если мы находимся в пространстве листа:
			(if (= (Getvar "TILEMODE") 0)
  ;если видовое окно не ативно dsc=1, если активно, то берем масштаб с видового экрана
			  (if (= (Getvar "CVPORT") 1)
			    (setq dsc 1)
			    (setq dsc (/ 1 (vla-get-CustomScale (vla-get-ActivePViewport (vla-get-ActiveDocument (vlax-get-Acad-Object))))))
			  );if
			 );if
      );progn
    );if
    dsc
    )

[VVA]

Krieger, Функции не те приложил

(Kr-AligmentText (* 1 (Kr_ScaleOfVP)) "ang" 0 p1 p2 (vlax-ename->vla-object (entlast)))

и

(defun Kr_AlignmentText (a An Justify / P1 P2 UL UT A1 A2 Pr)

[Krieger]

Ага, спасибо, подправил.

[megabeton]

Спасибо откликнувшимся!
Но все же, очень нужно, что бы слой текста соответствовал слою отрезка. Может кто поможет (ну или хоть намекните, как это исполнить)

[frostmourn]

Код:

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

;пишет длину всех выбранных отрезков
(defun c:lal (/ p1 p2 pt1 pt2 ent pr l)
(if (setq ss (ssget '((0 . "LINE"))))
  (progn
    (setq index -1
	    lr 0)
    (repeat (sslength ss)
      (setq index (1+ index)
	    pr (entget (ssname ss index))
	    pt1 (cdr (assoc 10 pr))
	    pt2 (cdr (assoc 11 pr))
	    L (Kr_roundof  (distance pt1 pt2) 1))
(vl-cmdf "_text" "0,0,0"
	 ;(* 2.5 (Kr_Scale nil))
	 "0" (rtos L 2 0))
(if (< (angtof "90") (angle pt1 pt2) (angtof "270.01" )) (setq p1 pt2 p2 pt1) (setq p1 pt1 p2 pt2))      
(Kr-AligmentText (* 1 (Kr_ScaleOfVP)) "ang" 0 p1 p2 (vlax-ename->vla-object (entlast)))
(vla-put-Layer (vlax-ename->vla-object (entlast)) (cdr (assoc 8 pr)))
      );repeat
  );rogn
  );if
  );defun

;|Функция Kr_roundof
Округление числа с заданным множителем.
num - число для округления (вводить вещественное число)
presc - множитель

Примеры
(Kr_roundof 45985. 3) 45984.0 
(Kr_roundof -45.56 3) -45.0 
(Kr_roundof 459. 5) 460.0
(Kr_roundof 459 5) 455.0 
(Kr_roundof 4.3 1.2) 4.8
(Kr_roundof 0.1 1.2) 0.0
|;
(defun Kr_roundof (num presc / )
(* (atof (rtos (/ num presc) 2 0)) presc)
  )

;|
Функция Kr_AligmentTextLine
*** Автор Морозов С.В. aka Krieger ***
Выравнивает Mtext и Text относительно двух точек
Параметры
а - величина смещения текста над линией
An - угол в градусах или "ang" - угол по линии
Justify - выравнивание текста для Mtext/Text:
	0 - BottomCenter
	1 - MiddleCenter
	2 - TopCenter
Примеры:
(Kr_AligmentTextLine (* 2 (Kr_ScaleOfVP)) "ang" 0) ;над линией
(Kr_AligmentTextLine 0 0 1) ;просто в центр
(Kr_AligmentTextLine (* -2 (Kr_ScaleOfVP)) "ang" 2) ;под линию
(Kr_AligmentTextLine 0 30 1) ;в центр, с фиксированным углом 30 градусов
|;

(defun Kr-AligmentText (a An Justify p1 p2 vl-ent / UL UL2 pt2 An2)
	    	(setq 	UL1 (angle P1 P2)
			p1 (trans p1 1 0)
			p2 (trans p2 1 0)
			UL2 (angle P1 P2)
			pt2 (polar (polar P1 (angle P1 P2) (/ (distance P1 P2) 2))
				   (+ (* (/ 90.0 180.0) pi)
				      (angle p1 p2))
				   a))
	      
		(cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbMText");если Mtext
			(cond
			  ((= Justify 0) (vla-put-AttachmentPoint  vl-ent acAttachmentPointBottomCenter))
			  ((= Justify 1) (vla-put-AttachmentPoint  vl-ent acAttachmentPointMiddleCenter))
			  ((= Justify 2) (vla-put-AttachmentPoint  vl-ent acAttachmentPointTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (* (/ An 180.0) pi))
		  (setq An2 UL1))
		   
		   (vla-put-InsertionPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbText");если Text
			(cond
			  ((= Justify 0) (vla-put-Alignment vl-ent acAlignmentBottomCenter))
			  ((= Justify 1) (vla-put-Alignment vl-ent acAlignmentMiddleCenter))
			  ((= Justify 2) (vla-put-Alignment vl-ent acAlignmentTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (+ (* (/ An 180.0) pi) (- UL2 UL1)))
		  (setq An2 UL2))
		   
		   (vla-put-TextAlignmentPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );
		  );cond
  );defun



;|---------------------------------------------------------------
Функция Kr_ScaleOfVP
-----------------------------------------------------------------
Вычисляет масштаб в зависимоти от переменной dimscale или CANNOSCALEVALUE, если dimscale=0 коэф-т = 1 или относительно vport
|;
(defun Kr_ScaleOfVP ( / )
  ;если текущим установлен аннотативный размерный стиль, масштаб берем с аннотативного масштаба
  (if (= (getvar "dimanno") 1)
    (setq dsc (/ 1 (getvar "CANNOSCALEVALUE")))
    (progn
  ;если dimscale=0 принимаем dsc=1, если нет dsc=dimscale
  			(if (= (getvar "dimscale") 0) (setq dsc 1) (setq dsc (getvar "dimscale")))
  ;если мы находимся в пространстве листа:
			(if (= (Getvar "TILEMODE") 0)
  ;если видовое окно не ативно dsc=1, если активно, то берем масштаб с видового экрана
			  (if (= (Getvar "CVPORT") 1)
			    (setq dsc 1)
			    (setq dsc (/ 1 (vla-get-CustomScale (vla-get-ActivePViewport (vla-get-ActiveDocument (vlax-get-Acad-Object))))))
			  );if
			 );if
      );progn
    );if
    dsc
    )

Как-то так. Думаю, понятно, что текущий слой должен быть разблокирован.

[megabeton]

Что то идет не так. Вот что пишет командная строка:

Команда: LAL Выберите объекты: Противоположный угол: найдено: 1 Выберите объекты: _text Текущий стиль текста: "ГОСТ 2.304" Высота текста: 125.0000 Аннотативный: Нет Выравнивание: сЛева Укажите начальную точку текста или [Выравнивание/Стиль]: 0,0,0 Высота <125.0000>: 0 Значение должно быть положительным и ненулевым. nil Высота <125.0000>: Угол поворота текста <0>:

После этого в пространстве модели с координатами 0,0,0 появляется поле ввода текста, моргает курсор, и все...

[Сергей812]

Вызывайте как _.-TEXT

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

Праальна, нефиг тексты создавать командными методами!

[megabeton]

Праальна, нефиг тексты создавать командными методами!

Тронут, до слез (в т.ч. и от смеха)
Но может все же кто-нибудь докрутит лисп до рабочего состояния...

[Sleekka]

Слишком условий много, некогда.

[frostmourn]

Код:

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

;пишет длину всех выбранных отрезков
(defun c:lal (/ p1 p2 pt1 pt2 ent pr l)
(if (setq ss (ssget '((0 . "LINE"))))
  (progn
    (setq index -1
	    lr 0)
    (repeat (sslength ss)
      (setq index (1+ index)
	    pr (entget (ssname ss index))
	    pt1 (cdr (assoc 10 pr))
	    pt2 (cdr (assoc 11 pr))
	    L (Kr_roundof  (distance pt1 pt2) 1))
(vla-addText (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object))) (rtos L 2 0) (vlax-3D-point '(0. 0. 0.)) (getvar "textsize"))
(if (< (angtof "90") (angle pt1 pt2) (angtof "270.01" )) (setq p1 pt2 p2 pt1) (setq p1 pt1 p2 pt2))      
(Kr-AligmentText (* 1 (Kr_ScaleOfVP)) "ang" 0 p1 p2 (vlax-ename->vla-object (entlast)))
(vla-put-Layer (vlax-ename->vla-object (entlast)) (cdr (assoc 8 pr)))
      );repeat
  );rogn
  );if
  );defun

;|Функция Kr_roundof
Округление числа с заданным множителем.
num - число для округления (вводить вещественное число)
presc - множитель

Примеры
(Kr_roundof 45985. 3) 45984.0 
(Kr_roundof -45.56 3) -45.0 
(Kr_roundof 459. 5) 460.0
(Kr_roundof 459 5) 455.0 
(Kr_roundof 4.3 1.2) 4.8
(Kr_roundof 0.1 1.2) 0.0
|;
(defun Kr_roundof (num presc / )
(* (atof (rtos (/ num presc) 2 0)) presc)
  )

;|
Функция Kr_AligmentTextLine
*** Автор Морозов С.В. aka Krieger ***
Выравнивает Mtext и Text относительно двух точек
Параметры
а - величина смещения текста над линией
An - угол в градусах или "ang" - угол по линии
Justify - выравнивание текста для Mtext/Text:
	0 - BottomCenter
	1 - MiddleCenter
	2 - TopCenter
Примеры:
(Kr_AligmentTextLine (* 2 (Kr_ScaleOfVP)) "ang" 0) ;над линией
(Kr_AligmentTextLine 0 0 1) ;просто в центр
(Kr_AligmentTextLine (* -2 (Kr_ScaleOfVP)) "ang" 2) ;под линию
(Kr_AligmentTextLine 0 30 1) ;в центр, с фиксированным углом 30 градусов
|;

(defun Kr-AligmentText (a An Justify p1 p2 vl-ent / UL UL2 pt2 An2)
	    	(setq 	UL1 (angle P1 P2)
			p1 (trans p1 1 0)
			p2 (trans p2 1 0)
			UL2 (angle P1 P2)
			pt2 (polar (polar P1 (angle P1 P2) (/ (distance P1 P2) 2))
				   (+ (* (/ 90.0 180.0) pi)
				      (angle p1 p2))
				   a))
	      
		(cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbMText");если Mtext
			(cond
			  ((= Justify 0) (vla-put-AttachmentPoint  vl-ent acAttachmentPointBottomCenter))
			  ((= Justify 1) (vla-put-AttachmentPoint  vl-ent acAttachmentPointMiddleCenter))
			  ((= Justify 2) (vla-put-AttachmentPoint  vl-ent acAttachmentPointTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (* (/ An 180.0) pi))
		  (setq An2 UL1))
		   
		   (vla-put-InsertionPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbText");если Text
			(cond
			  ((= Justify 0) (vla-put-Alignment vl-ent acAlignmentBottomCenter))
			  ((= Justify 1) (vla-put-Alignment vl-ent acAlignmentMiddleCenter))
			  ((= Justify 2) (vla-put-Alignment vl-ent acAlignmentTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (+ (* (/ An 180.0) pi) (- UL2 UL1)))
		  (setq An2 UL2))
		   
		   (vla-put-TextAlignmentPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );
		  );cond
  );defun



;|---------------------------------------------------------------
Функция Kr_ScaleOfVP
-----------------------------------------------------------------
Вычисляет масштаб в зависимоти от переменной dimscale или CANNOSCALEVALUE, если dimscale=0 коэф-т = 1 или относительно vport
|;
(defun Kr_ScaleOfVP ( / )
  ;если текущим установлен аннотативный размерный стиль, масштаб берем с аннотативного масштаба
  (if (= (getvar "dimanno") 1)
    (setq dsc (/ 1 (getvar "CANNOSCALEVALUE")))
    (progn
  ;если dimscale=0 принимаем dsc=1, если нет dsc=dimscale
  			(if (= (getvar "dimscale") 0) (setq dsc 1) (setq dsc (getvar "dimscale")))
  ;если мы находимся в пространстве листа:
			(if (= (Getvar "TILEMODE") 0)
  ;если видовое окно не ативно dsc=1, если активно, то берем масштаб с видового экрана
			  (if (= (Getvar "CVPORT") 1)
			    (setq dsc 1)
			    (setq dsc (/ 1 (vla-get-CustomScale (vla-get-ActivePViewport (vla-get-ActiveDocument (vlax-get-Acad-Object))))))
			  );if
			 );if
      );progn
    );if
    dsc
    )

Опять же, если по-простому, то так. Только сразу добавляются новые ограничения - работает только в модели, высота текста может отличаться от стиля. Вообще да, по-хорошему, надо под конкретные требования делать.

[megabeton]

frostmourn, дай бог тебе здоровья, мил человек! То, что нужно!
Теперь имеем:
- слой отрисовываемого текста соответствовует слою отрезка;
- выравнивание отрисовываемого текста производится "вниз по центру"

По остальному:
- добавить возможность работы с полилиниями и прочими примитивами (окружности, дуги и т.д.) - решил все "взрывать" до отрезков (окружности и дуги мне не особо важны);
- добавить возможность установки поправочного коэффициента; - решил лиспом

Код:

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

(defun c:умн (/     sys-var  selset       action
        value     precision_value       str
        precision_str   rec-pat
       )
  (defun rec-pat (str / rec-pat)
    (defun rec-pat (temp str pat n /)
      (cond ((= str "") (list temp))
     ((if (minusp n)
        (not (member (substr str 1 1) pat))
        (member (substr str 1 1) pat)
      ) ;_ end of if
      (if (/= temp "")
        (cons temp (rec-pat "" str pat (- n)))
        (rec-pat "" str pat (- n))
      ) ;_ end of if
     )
     (t
      (rec-pat (strcat temp (substr str 1 1))
        (substr str 2)
        pat
        n
      ) ;_ end of trim_gap
     )
      ) ;_ end of cond
    ) ;_ end of defun
    (rec-pat ""
      str
      '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" ".")
      1
    ) ;_ end of rec-pat
  ) ;_ end of defun
  (setq sys-var (getvar 'dimzin))
  (setvar 'dimzin 0)
  (if
    (and
      (setq selset (ssget "_:L" '((0 . "TEXT"))))
      (not
 (vl-catch-all-error-p
   (vl-catch-all-apply
     '(lambda ()
        (setq action
        (progn
   (initget "+ - * /")
   (cadr
     (assoc (getkword
       "Действие [+ - * /] :<+> "
     ) ;_ end of getkword
     '(("+" +) ("-" -) ("*" *) ("/" /) (nil +))
     ) ;_ end of assoc
   ) ;_ end of cadr
        ) ;_ end of progn
        ) ;_ end of setq
        (setq value (getreal "\nЧисло <Esc> : "))
        (setq
   precision_value
    ((lambda (x)
       (if (equal x 0.0)
         0
         (- (length
       (vl-string->list
         (vl-princ-to-string
    x
         ) ;_ end of vl-princ-to-string
       ) ;_ end of vl-string->list
     ) ;_ end of length
     2
         ) ;_ end of -
       ) ;_ end of if
     ) ;_ end of lambda
      (rem value 1.)
    )
        ) ;_ end of setq
      ) ;_ end of lambda
   ) ;_ end of vl-catch-all-apply
 ) ;_ end of vl-catch-all-error-p
      ) ;_ end of not
    ) ;_ end of and
     (foreach ent
       (mapcar
  'vlax-ename->vla-object
  (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
       ) ;_ end of mapcar
       (setq str (vla-get-textstring ent))
       (vla-put-textstring
  ent
  (apply 'strcat
  (mapcar
    '(lambda (str)
       (setq precision_str
       (length
         (cdr (member 46 (vl-string->list str)))
       ) ;_ end of length
       ) ;_ end of setq
       (if (equal (rtos (atof str) 2 precision_str) str)
         (rtos
    ((eval action) (atof str) value)
    2
    (apply 'max (list precision_value precision_str))
         ) ;_ end of rtos
         str
       ) ;_ end of if
     ) ;_ end of lambda
    (rec-pat str)
  ) ;_ end of mapcar
  ) ;_ end of apply
       ) ;_ end of vla-put-textstring
       (vla-put-color ent 3)
     ) ;_ end of foreach
  ) ;_ end of if
  (setvar 'dimzin sys-var)
  (princ)
) ;_ end of defun

- добавить возможность установки необходимого округления/точности; - тут еще не решил, т.к. калькулятор (лисп выше) при умножении допустим на число 0,00284 полученные результаты выдает с 5-ю знаками после запятой, и если нужно меньше знаков после запятой, приходится умножать два раза (как пример 0,001 и 2,84). Может кто выделит цветом в коде, как там rtos подправить, а то пробовал, не получилось.
- добавить возможность установки высоты текста; - ну это легко, через свойства, оно собственно и не особо нужно в лисп встраивать.

[DEM]

Нужна похожая функция.
Только надо поставить на концах отрезка блоки, а по центру отрезка текст с выравниванием по середине.

Код:

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

   (defun c:1 ()
	(setq nab(ssget))
	(setq kol (sslength nab))
	(setq n -1)
	(repeat kol
		(setq n (+ n 1))
		(setq pr (ssname nab n))
		(setq t_1 (cdr (assoc '10 (entget pr))))
		(setq t_2 (cdr (assoc '11 (entget pr))))
		(setq t_3 (list
        (/ (+ (car t_1) (car t_2)) 2)
        (/ (+ (cadr t_1) (cadr t_2)) 2)
        (/ (+ (caddr t_1) (caddr t_2)) 2))
		(command "_-insert" "01" t_1 "1" "1" "0")
		(command "_-insert" "01" t_2 "1" "1" "0")
		(command "_.-text" "В" "ВЦ" t_3 "0.1" "0" "WDWD")
	)
)
)

----- добавлено через ~53 мин. -----
Переделал....

Код:

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

  (defun c:1 ()
	(setq nab(ssget))
	(setq kol (sslength nab))
	(setq n -1)
	(repeat kol
		(setq n (+ n 1))
		(setq pr (ssname nab n))
		(setq t_1 (cdr (assoc '10 (entget pr))))
		(setq t_2 (cdr (assoc '11 (entget pr))))
		(setq x (+ (car t_1) (/ (- (car t_2) (car t_1)) 2))
		y (+(cadr t_1) (/ (- (cadr t_2) (cadr t_1)) 2)))
		(setq t_3 (list x y))
		(command "_-insert" "01" t_1 "1" "1" "0")
		(command "_-insert" "01" t_2 "1" "1" "0")
		(command "_TEXT" "_M" t_3 "0.05" "0" "SSC")
	)
)

[VVA]

DEM, чтобы не зависеть от текущих привязок в command перед указанием точек добавь "_non"

(command "_-insert" "01" "_non" t_2 "1" "1" "0") (command "_TEXT" "_M" "_non" t_3 "0.05" "0" "SSC")

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

Ну или вообще использовать некомандные методы.
P.S. Код не проверяет наличие блока "01" в чертеже, так что...

[DEM]

Да всё норм.
Это разовый лисп, отработал как надо.

[tr0ll]

Сообщение от frostmourn L (Kr_roundof (distance pt1 pt2) 1))

Что в коде изменить, чтобы округление было до сотых? Заранее спасибо!

[megabeton]

(rtos L 2 2)

[Мертвая наука]

Подниму тему. Было бы еще лучше если доделать лисп, чтобы он не текст выдавал, а поле. Естественно поле бы ссылалось на обьект и значение длины линии. Я не умею в код к сожалению...

[VVA]

Сообщение от Мертвая наука чтобы он не текст выдавал, а поле

пробуй

Код:

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

(defun c:lalF (/ p1 p2 pt1 pt2 ent pr l fld en)
;_пишет длину всех выбранных отрезков полем
;_в строке ">%).Length \\f \"%lu2%pr2\">%"
;_ pr2 - 2 знака после запятой
;_ pr3 - 3 знака после запятой
;_https://forum.dwg.ru/showthread.php?t=130372  
(vl-load-com)
(if (setq ss (ssget '((0 . "LINE"))))
  (progn
    (setq index -1
	    lr 0)
    (repeat (sslength ss)
      (setq index (1+ index)
            en (ssname ss index)
	    pr (entget en)
	    pt1 (cdr (assoc 10 pr))
	    pt2 (cdr (assoc 11 pr))
	    L (Kr_roundof  (distance pt1 pt2) 1))
      (setq fld (strcat
                "%<\\AcObjProp Object(%<\\_ObjId "
                (vl-princ-to-string
                  (Get-ObjectID-x86-x64 (vlax-ename->vla-object en))
                  ) ;_ vl-princ-to-string
                ">%).Length \\f \"%lu2%pr2\">%"
                ) ;_ strcat
          )
;_ (vla-addText (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object))) (rtos L 2 0) (vlax-3D-point '(0. 0. 0.)) (getvar "textsize")) ;_rem VVA 2023-03-06
(vla-addText (vla-get-ModelSpace (vla-get-activedocument (vlax-get-acad-object))) fld (vlax-3D-point '(0. 0. 0.)) (getvar "textsize"))      
(if (< (angtof "90") (angle pt1 pt2) (angtof "270.01" )) (setq p1 pt2 p2 pt1) (setq p1 pt1 p2 pt2))      
(Kr-AligmentText (* 1 (Kr_ScaleOfVP)) "ang" 0 p1 p2 (vlax-ename->vla-object (entlast)))
(vla-put-Layer (vlax-ename->vla-object (entlast)) (cdr (assoc 8 pr)))
      );repeat
  );rogn
  );if
  );defun

;|Функция Kr_roundof
Округление числа с заданным множителем.
num - число для округления (вводить вещественное число)
presc - множитель

Примеры
(Kr_roundof 45985. 3) 45984.0 
(Kr_roundof -45.56 3) -45.0 
(Kr_roundof 459. 5) 460.0
(Kr_roundof 459 5) 455.0 
(Kr_roundof 4.3 1.2) 4.8
(Kr_roundof 0.1 1.2) 0.0
|;
(defun Kr_roundof (num presc / )
(* (atof (rtos (/ num presc) 2 0)) presc)
  )

;|
Функция Kr_AligmentTextLine
*** Автор Морозов С.В. aka Krieger ***
Выравнивает Mtext и Text относительно двух точек
Параметры
а - величина смещения текста над линией
An - угол в градусах или "ang" - угол по линии
Justify - выравнивание текста для Mtext/Text:
	0 - BottomCenter
	1 - MiddleCenter
	2 - TopCenter
Примеры:
(Kr_AligmentTextLine (* 2 (Kr_ScaleOfVP)) "ang" 0) ;над линией
(Kr_AligmentTextLine 0 0 1) ;просто в центр
(Kr_AligmentTextLine (* -2 (Kr_ScaleOfVP)) "ang" 2) ;под линию
(Kr_AligmentTextLine 0 30 1) ;в центр, с фиксированным углом 30 градусов
|;

(defun Kr-AligmentText (a An Justify p1 p2 vl-ent / UL UL2 pt2 An2)
	    	(setq 	UL1 (angle P1 P2)
			p1 (trans p1 1 0)
			p2 (trans p2 1 0)
			UL2 (angle P1 P2)
			pt2 (polar (polar P1 (angle P1 P2) (/ (distance P1 P2) 2))
				   (+ (* (/ 90.0 180.0) pi)
				      (angle p1 p2))
				   a))
	      
		(cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbMText");если Mtext
			(cond
			  ((= Justify 0) (vla-put-AttachmentPoint  vl-ent acAttachmentPointBottomCenter))
			  ((= Justify 1) (vla-put-AttachmentPoint  vl-ent acAttachmentPointMiddleCenter))
			  ((= Justify 2) (vla-put-AttachmentPoint  vl-ent acAttachmentPointTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (* (/ An 180.0) pi))
		  (setq An2 UL1))
		   
		   (vla-put-InsertionPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );cond
		  ((eq (vla-get-ObjectName vl-ent) "AcDbText");если Text
			(cond
			  ((= Justify 0) (vla-put-Alignment vl-ent acAlignmentBottomCenter))
			  ((= Justify 1) (vla-put-Alignment vl-ent acAlignmentMiddleCenter))
			  ((= Justify 2) (vla-put-Alignment vl-ent acAlignmentTopCenter))
			  )
		   
		(if (or (eq (type An) 'INT)
			(eq (type An) 'REAL))
		  (setq An2 (+ (* (/ An 180.0) pi) (- UL2 UL1)))
		  (setq An2 UL2))
		   
		   (vla-put-TextAlignmentPoint vl-ent (vlax-3D-point pt2))
		   (vla-put-Rotation vl-ent An2)
		   );
		  );cond
  );defun



;|---------------------------------------------------------------
Функция Kr_ScaleOfVP
-----------------------------------------------------------------
Вычисляет масштаб в зависимоти от переменной dimscale или CANNOSCALEVALUE, если dimscale=0 коэф-т = 1 или относительно vport
|;
(defun Kr_ScaleOfVP ( / )
  ;если текущим установлен аннотативный размерный стиль, масштаб берем с аннотативного масштаба
  (if (= (getvar "dimanno") 1)
    (setq dsc (/ 1 (getvar "CANNOSCALEVALUE")))
    (progn
  ;если dimscale=0 принимаем dsc=1, если нет dsc=dimscale
  			(if (= (getvar "dimscale") 0) (setq dsc 1) (setq dsc (getvar "dimscale")))
  ;если мы находимся в пространстве листа:
			(if (= (Getvar "TILEMODE") 0)
  ;если видовое окно не ативно dsc=1, если активно, то берем масштаб с видового экрана
			  (if (= (Getvar "CVPORT") 1)
			    (setq dsc 1)
			    (setq dsc (/ 1 (vla-get-CustomScale (vla-get-ActivePViewport (vla-get-ActiveDocument (vlax-get-Acad-Object))))))
			  );if
			 );if
      );progn
    );if
    dsc
    )
;;--------------------------------------------------------
;; Функция получает строковое представление ObjectID
;; вне зависимости от того AutoCAD x86 или x64
;; Источник: "Field and objectid problem"
;;http://forums.autodesk.com/t5/Visual-LISP-AutoLISP-and-General/Field-and-objectid-problem/m-p/2478592/highlight/true#M276818
;; http://forum.dwg.ru/showthread.php?t=51822
;; https://autolisp.ru/2011/07/07/x32x64objectid/
;;--------------------------------------------------------
(defun Get-ObjectID-x86-x64 (obj / util)
  (setq util (vla-get-Utility (vla-get-activedocument (vlax-get-acad-object))))
  (if (= (type obj) 'ENAME)(setq obj (vlax-ename->vla-object obj)))
  (if (= (type obj) 'VLA-OBJECT)
     (if (> (vl-string-search "x64" (getvar "platform")) 0)
       (vlax-invoke-method util "GetObjectIdString" obj :vlax-False)
       (rtos (vla-get-objectid obj) 2 0)
     )
  )
)

pr2 - 2 знака после запятой
pr3 - 3 знака после запятой

Еще похожая тема Добавление в чертеж длины полилинии