| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Как подписать длины всех выбранных отрезков

Как подписать длины всех выбранных отрезков

Ответ
Поиск в этой теме
Непрочитано 25.03.2016, 19:04 #1
Как подписать длины всех выбранных отрезков
megabeton
 
Регистрация: 03.12.2009
Сообщений: 84

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

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

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

Вложения
Тип файла: lsp длот.lsp (928 байт, 226 просмотров)

Просмотров: 14838
 
Непрочитано 25.03.2016, 19:25
#2
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,772


А в каких строках у тебя проблемы? Посмотри DXF Reference - там много интересного. Или ты ошибся с разделом, и тебе в "Поиск исполнителей"?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 25.03.2016, 19:30
#3
megabeton


 
Регистрация: 03.12.2009
Сообщений: 84


Да, мне в поиск исполнителей...
megabeton вне форума  
 
Непрочитано 25.03.2016, 19:42
#4
trir


 
Регистрация: 18.12.2010
Сообщений: 5,047


усё готово
trir вне форума  
 
Непрочитано 26.03.2016, 08:32
#5
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,825


Пользуюсь вот таким, несколько кустарно, но работает. Команда 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
    )
__________________
Делай хорошо, плохо само получится.

Последний раз редактировалось Krieger, 26.03.2016 в 11:06.
Krieger вне форума  
 
Непрочитано 26.03.2016, 10:38
#6
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


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)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 26.03.2016, 11:06
#7
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,825


Ага, спасибо, подправил.
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Автор темы   Непрочитано 05.04.2016, 14:38
#8
megabeton


 
Регистрация: 03.12.2009
Сообщений: 84


Спасибо откликнувшимся!
Но все же, очень нужно, что бы слой текста соответствовал слою отрезка. Может кто поможет (ну или хоть намекните, как это исполнить)
megabeton вне форума  
 
Непрочитано 05.04.2016, 15:37
#9
frostmourn


 
Регистрация: 23.04.2015
Сообщений: 163


Код:
[Выделить все]
;пишет длину всех выбранных отрезков
(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
    )
Как-то так. Думаю, понятно, что текущий слой должен быть разблокирован.
frostmourn вне форума  
 
Автор темы   Непрочитано 05.04.2016, 16:24
#10
megabeton


 
Регистрация: 03.12.2009
Сообщений: 84


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

Выберите объекты: Противоположный угол: найдено: 1

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

Высота <125.0000>:

Угол поворота текста <0>:
После этого в пространстве модели с координатами 0,0,0 появляется поле ввода текста, моргает курсор, и все...
megabeton вне форума  
 
Непрочитано 05.04.2016, 16:33
#11
Сергей812


 
Регистрация: 10.08.2013
Сообщений: 10,960


Вызывайте как _.-TEXT
Сергей812 вне форума  
 
Непрочитано 05.04.2016, 17:02
#12
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,772


Праальна, нефиг тексты создавать командными методами!
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 05.04.2016, 17:46
#13
megabeton


 
Регистрация: 03.12.2009
Сообщений: 84


Цитата:
Праальна, нефиг тексты создавать командными методами!
Тронут, до слез (в т.ч. и от смеха)
Но может все же кто-нибудь докрутит лисп до рабочего состояния...
megabeton вне форума  
 
Непрочитано 05.04.2016, 22:52
#14
Sleekka

-
 
Регистрация: 24.07.2005
Москва
Сообщений: 1,335


Слишком условий много, некогда.
Sleekka вне форума  
 
Непрочитано 06.04.2016, 09:54
#15
frostmourn


 
Регистрация: 23.04.2015
Сообщений: 163


Код:
[Выделить все]
;пишет длину всех выбранных отрезков
(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
    )

Опять же, если по-простому, то так. Только сразу добавляются новые ограничения - работает только в модели, высота текста может отличаться от стиля. Вообще да, по-хорошему, надо под конкретные требования делать.
frostmourn вне форума  
 
Автор темы   Непрочитано 06.04.2016, 15:28
#16
megabeton


 
Регистрация: 03.12.2009
Сообщений: 84


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 подправить, а то пробовал, не получилось.
- добавить возможность установки высоты текста; - ну это легко, через свойства, оно собственно и не особо нужно в лисп встраивать.

Последний раз редактировалось megabeton, 06.04.2016 в 16:04.
megabeton вне форума  
 
Непрочитано 18.10.2019, 15:45
#17
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,968


Нужна похожая функция.
Только надо поставить на концах отрезка блоки, а по центру отрезка текст с выравниванием по середине.
Код:
[Выделить все]
   (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")
	)
)
__________________
Работаю за еду.
Working for food.
Für Essen arbeiten.
العمل من أجل الغذاء
Працую за їжу.
DEM вне форума  
 
Непрочитано 18.10.2019, 19:15
#18
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,990
<phrase 1= Отправить сообщение для VVA с помощью Skype™


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

Цитата:
(command "_-insert" "01" "_non" t_2 "1" "1" "0")
(command "_TEXT" "_M" "_non" t_3 "0.05" "0" "SSC")
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 18.10.2019, 20:58
#19
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,772


Ну или вообще использовать некомандные методы.
P.S. Код не проверяет наличие блока "01" в чертеже, так что...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 19.10.2019, 00:51
#20
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,968


Да всё норм.
Это разовый лисп, отработал как надо.
__________________
Работаю за еду.
Working for food.
Für Essen arbeiten.
العمل من أجل الغذاء
Працую за їжу.
DEM вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Как подписать длины всех выбранных отрезков

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Разработка ПОС, искусство проектирования Tyhig Технология и организация строительства 117 25.11.2021 17:38
Общая длина всех отрезков. SanchouZ AutoCAD 33 25.07.2016 11:49
Экспорт в Excel длины всех участков полилинии Meddoks Программирование 22 09.09.2013 22:52
Инструмент определения общей длины всех выделенных линий лежащих в разных плоскостях в AUTOCAD 2006 Геннадий+ AutoCAD 3 01.10.2009 18:33
Определение суммарной длины отрезков Александр Шевелев Программирование 1 16.12.2007 23:10