[casaatik]

Здравствуйте знатоки Автокада.
Искал про форуму, но ничего похожего не нашел.
В программе Total purge (debalance) встретил функцию «конвертации одинаковой группы примитивов в блок», поэтому возник вопрос, возможно, есть lisp который без лишних очисток производит (повторюсь) «ПРЕОБРАЗОВАНИЕ ОДИНАКОВЫХ ГРУП ПРИМИТИВОВ В БЛОК». Группы примитивов одинаковы на 100%, так как раньше были блоками и подверглись случайному расчленению, что в свою очередь привело к большому увеличению размера файла.
Заранее благодарен за ответ

[Apelsinov]

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

сначала программа запросит указать первоначальную группу, затем область поиска. Найденные объекты будут преобразованы во вставки блока, содержащего первоначальную группу.
Программа определяет идентичность групп только по геометрии, все остальные свойства (цвета, слои и т.д) не учитываются.

брать тут: http://dwg.ru/dnl/9487, загрузить через appload,

код запуска программы - в ком строку (или в кнопку/ палитру / меню и т.п.)
(apel-com '(apel-draw-find_analog_objects))

[Ilez]

Сообщение от Apelsinov брать тут: http://dwg.ru/dnl/9487, загрузить через appload, код запуска программы - в ком строку (или в кнопку/ палитру / меню и т.п.) (apel-com '(apel-draw-find_analog_objects))

Доброго времени суток. Загрузил вашу программу по ссылке. При вводе в ком. строку команда запускается, работает и только при последнем вводе пишет в командной строке "не получилось". В чём может быть дело, не знаете?

[Apelsinov]

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

В программе нет определения для множества случаев, когда введенные данные не позволяют получить результат - вместо этого просто выводится "не получилось".

[Ilez]

Сообщение от Apelsinov судя по скрину - вы вообще ничего не выбирали, отсюда и ошибка. Сначала надо выбрать те объекты, которые вы ищете, затем, те, среди которых хотите найти аналогичные.

Распишу подробно:
-ввёл команду в ком. строку;
-просит выбрать объекты "выберете объекты для поиска таких же", я выбрал, напр., 1 круг и нажал Enter;
-далее "выберете объекты среди которых нужно искать", выделяю рамкой нужные объекты, в ком. строке написано "найдено 36"
-жму Enter.
На скрине же выведено это, что я сначала выбрал 1 объект, потом (после Enter) выделил 36 объектов. Акад 2014.

[VVA]

Из описания Debalance Optitool

•Преобразование геометрически идентичных замкнутых двумерных контуров в набор однотипных блоков при помощи нового эффективного инструмента генератора блоков. •Оптимизация данных внутри блоков с применением всех вышеперечисленных возможностей. •Конвертация объектов в полилинии внутри блоков методами тривиальной и интеллектуальной конвертации. •Высокая скорость работы программы при обработке большого количества блоков.

[Apelsinov]

Ilez, да, вы правы, я невнимательно на скрин глядел

но что у вас там я не знаю, может программа просто не нашла аналогичных объектов

[casaatik]

2 Apelsinov
В программе из второго сообщения много других функций. Можете выложить перечень с командами запуска?
И еще как для команды вида
(apel-com '(apel-draw-find_analog_objects))
создать алиас? (прописать в файл acad.pgp

[Ilez]

Сообщение от Apelsinov но что у вас там я не знаю, может программа просто не нашла аналогичных объектов

да я для проверки специально их копировал, чтобы точно были аналогичными.
Ну да ладно, спасибо, если вдруг найду проблему - отпишусь.

Сообщение от VVA Из описания Debalance Optitool

VVA, спасибо. Я так понял программа может преобразовать в вхождения блоков только замкнутые объекты.

[Apelsinov]

Ilez, есть вариант, что вы выложите сюда свой тестовый файл, а я проверю, что там не так.

Сообщение от casaatik В программе из второго сообщения много других функций. Можете выложить перечень с командами запуска?

там очень много, мне лень

Сообщение от casaatik И еще как для команды вида (apel-com '(apel-draw-find_analog_objects)) создать алиас? (прописать в файл acad.pgp

вот так:
(defun c:имя_комманды () (apel-com '(apel-draw-find_analog_objects)))
эту строку вставляете в файл *.lsp, который кидате в автозапуск.

[Ilez]

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

Сам стеснялся предложить. И ещё была идея, вытащить код именно этой команды и выложить в виде LSP-файла, насколько мне известно, FAS-файлы тоже на лиспе пишутся.

[Apelsinov]

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

Ниже код. могут быть пользовательские функции. Уж и не знаю кому охота будет в этом копаться.

Код:

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

 defun apel-draw-find_analog_objects (/		   SS
				      LIST_SS PT2
				      SS0	   list_pt_1
				      opt_2	   OPT_3
				      list_pt_2	   OPT_1
				      list_obj_SS  list_coord_SS
				      List_list_pt LIST_BOXES_SS
				      blk_obj	   LIST_OBJ_SS_LENGTH
				      P1	   P2 list_blocks
				      N POINT_0
				     )
;;;САМАЯ ОФИГИТЕЛЬНАЯ ФУНКЦИЯ
;;;  (apel-com '(apel-draw-find_analog_objects))
;;;-------< ЛОКАЛЬНЫЕ ФУНКЦИИ >------
  (defun _APEL-DRAW-RECTANGLE (list_2_points / pt1 p2 pt3 pt4)
;;;  Отрисовка прямоугольника по двум точкам
    (setq pt1 (car list_2_points))
    (setq pt3 (cadr list_2_points))
    (setq pt2 (list (car pt1) (cadr pt3) 0.0))
    (setq pt4 (list (car pt3) (cadr pt1) 0.0))
    (APEL-DRAW-POLYLINE (list pt1 pt2 pt3 pt4 pt1))
  )
  (defun _apel-point-coord_calc	(xy0 xy xy_ /)
;;;xy0 - координаты относительной точки 0 в глобальной системе
;;;xy - координаты искомой точки в глобальной системе
;;;xy_ - координаты точки относительно точки 0
;;;xy и xy_ могут иметь значение nil
;;;возврат:
;;;xy = nil -> высчитывается xy_
;;;xy_ = nil -> высчитывается xy
;;;  (apel-point-coord_calc '(1 1 0.0) '(3 3 0.0) nil)	-> (2 2 0.0)
;;;  (apel-point-coord_calc '(1 1 0.0) nil '(2 2 0.0))	-> (3 3 0.0)
    (cond
      ((null xy0) (mapcar '- xy xy_))
      ((null xy_) (mapcar '- xy xy0))
      ((null xy) (mapcar '+ xy_ xy0))
    )
  )
    (defun _apel-obj-compare_box (list_pt_0 obj / list_pt_obj)
;;;  Сравнение габаритов
;;;  арг:
;;;  list_pt_0 - относительные габариты для сравнения
;;;  obj - объект для сравнения
;;;  воз:
;;;  абсолютные габариты по объекту, либо nil
    (setq list_pt_obj (apel-BoundingBox obj))
    (if	(equal (_apel-point-coord_calc
		 (car list_pt_obj)
		 (cadr list_pt_obj)
		 nil
	       )
	       list_pt_0
	       0.001
	)
      list_pt_obj
    )
  )
  (defun _apel-BoundingBox_abs->box_otn	(point_0 list_objects)
;;;Получение относительных координат габаритов обьектов по списку
;;;арг:
;;;point_0 - точка, относительно которой пересчитываются координаты
;;;list_objects - список объектов, для получения габаритов
;;; воз: список координат габаритов относительно данной точки, либо nil
    (mapcar (FUNCTION
	      (lambda (i / a)
		(if (setq a (apel-BoundingBox i))
		  (list	(_apel-point-coord_calc point_0 (car a) nil)
			(_apel-point-coord_calc point_0 (cadr a) nil)
		  )
		)
	      )
	    )
	    list_objects
    )
  )
;;;-------< КОНЕЦ ЛОКАЛЬНЫХ ФУНКЦИЙ >------


  (if (and
	(princ "\n Выберите объекты для поиска таких-же:")
	(setq SS (apel-ssget 'nil))	;выборка первая
	(setq list_pt_1 (apel-BoundingBox SS))
					; координаты габаритов первой выборки
	(setq opt_1 (_apel-point-coord_calc
		      (car list_pt_1)
		      (cadr list_pt_1)
		      nil
		    )
	)				;Относительные координаты второй точки габаритов
	(setq list_pt_2 (apel-BoundingBox (vla-item SS 0)))
					;Габариты поискового объекта
	(vlax-for i SS
	  (setq list_obj_SS (cons i list_obj_SS))
	)				;Список объектов из первой выборки
	(princ "\n Выберите объекты среди которых нужно искать:")
	(setq SS0 (apel-ssget 'nil))	;выборка общая, то есть среди чего ищем
	(setq opt_2 (_apel-point-coord_calc
		      (car list_pt_2)
		      (cadr list_pt_2)
		      nil
		    )
	)				;Относительные габариты поискового объекта
	(vlax-for i SS0			; Нахождение списка похожих габаритов по объектам
	  (setq	List_list_pt
		 (cons (_apel-obj-compare_box opt_2 i)
		       List_list_pt
		 )
	  )
	)
	(setq List_list_pt (VL-REMOVE-IF 'null List_list_pt))
	(setq opt_3 (_apel-point-coord_calc
		      (car list_pt_1)
		      (car list_pt_2)
		      nil
		    )
	)				; относительные координаты точки объекта
	(setq
	  list_coord_SS
	   (mapcar
	     (FUNCTION
	       (LAMBDA (i / a)
		 (list
		   (setq a
			  (_apel-point-coord_calc nil i opt_3)
		   )
		   (_apel-point-coord_calc a nil opt_1)
		 )
	       )
	     )
	     (mapcar 'car List_list_pt)
	   )
	)				;Координаты найденых габаритов всех выборок
;;;	(mapcar '_APEL-DRAW-RECTANGLE list_coord_SS)
					; Отрисовываем прямоугольник вокруг каждой будущей выборки

	(setq
	  list_SS (mapcar (FUNCTION
			    (LAMBDA (i / SSi list_obj)
			      (if (setq	SSi
					 (apel-ssget
					   (list
					     "W"
					     (APEL-POINT-LIST_TO_VARIANT
					       (car i)
					     )
					     (APEL-POINT-LIST_TO_VARIANT
					       (cadr i)
					     )
					   )
					 )
				  )
				(vlax-for obj SSi
				  (setq list_obj (cons obj list_obj))
				)
			      )
			      list_obj
			    )
			  )
			  list_coord_SS
		  )
	)				; Создание списка списков объектов по найденным выборкам
	(setq list_obj_SS_LENGTH (LENGTH list_obj_SS))
					; кол-во объектов в первой выборке

	(setq list_SS (mapcar 'list list_coord_SS list_SS))
					; создание списка типа (((коорд_выборки_1)(объекты_этой_выборки_1))((коорд_выборки_2)(объекты_этой_выборки_2))...)

	(setq list_SS
	       (VL-REMOVE-IF
		 (FUNCTION
		   (LAMBDA (i) (< (LENGTH (cadr i)) list_obj_SS_LENGTH))
		 )
		 list_SS
	       )
	)				; отфильтровываем выборки в которых элементов меньше, чем в первой

	(setq list_boxes_SS
	       (_apel-BoundingBox_abs->box_otn
		 (car list_pt_1)
		 list_obj_SS
	       )
	)				;список отн. координат габаритов объектов первой выборки

	(setq list_SS
	       (mapcar (FUNCTION
			 (lambda (i / a b)
			   (list (setq a (caar i))
				 (setq b (cadr i))
				 (_apel-BoundingBox_abs->box_otn a b)
			   )
			 )
		       )
		       list_SS
	       )
	)				; список  типа (((коорд_выборки_1)(объекты_этой_выборки_1)(отн_габариты_объектов_выборки))...)

	(setq list_SS
	       (mapcar
		 (FUNCTION
		   (lambda (c)
		     (list
		       (car c)
		       (vl-remove-if
			 'null
			 (mapcar
			   (function (LAMBDA (a b) (cond (a b))))
			   (mapcar
			     (FUNCTION
			       (lambda (b)
				 (apply	'or
					(mapcar	(FUNCTION (lambda (i)
							    (equal i b 0.001)
							  )
						)
						list_boxes_SS
					)
				 )
			       )
			     )
			     (caddr c)
			   )
			   (cadr c)
			 )
		       )
		     )
		   )
		 )
		 list_SS
	       )
	)				; список  типа (((коорд_выборки_1)(объекты_этой_выборки_1_но только те, что соответствуют)...)
	(setq
	  list_SS (vl-remove-if
		    (FUNCTION
		      (LAMBDA (i)
			(< (LENGTH (cadr i)) list_obj_SS_LENGTH)
		      )
		    )
		    list_SS
		  )
	)				; Отфильтровываем выборки в которых совпавших объектов меньше, чем в исходной
;;;	В результате получили список выборок в которых есть объекты полностью соответствующие, и эти объекты даны списком
	(while (null blk_obj)
	  (setq	N (cond	(N (1+ N))
			(1)
		  )
	  )
	  (setq
	    blk_obj (apel-block-add_document
		      (strcat "apel-draw-find_analog_objects_"
			      (rtos (apel_rand) 2 0)
			      (rtos N 2 0)
		      )
		    )
	  )
	)				; Создаем пустой блок с оригинальным именем


	(setq p1 (APEL-POINT-LIST_TO_VARIANT (car list_pt_1))
	      p2 (APEL-POINT-LIST_TO_VARIANT (list 0.0 0.0 0.0))
	)

	(mapcar	(FUNCTION
		  (LAMBDA (i)
		    (vla-move i
			      p1
			      p2
		    )
		  )
		)
		(APEL-POINT-VARIANT_TO_LIST
		  (vla-copyobjects
		    (APEL-ACTIVE_DOCUMENT)
		    (vlax-make-variant
		      (vlax-safearray-fill
			(vlax-make-safearray
			  vlax-vbobject
			  (cons 0 (1- (length list_obj_SS)))
			)
			list_obj_SS
		      )
		    )
		    blk_obj
		  )
		)
	)				;Создание блока с элементами из первой выборки
	(setq list_blocks
	       (mapcar (FUNCTION (LAMBDA (i)
				   (APEL-BLOCK-INSERT
				     (APEL-MOD-GET_PROPERTY blk_obj 'Name)
				     (APEL-POINT-LIST_TO_VARIANT i)
				     1
				     1
				     1
				     0
				   )
				 )
		       )
		       (mapcar 'car list_SS)
	       )
	)				;Вставляем созданный блок на место найденных выборок
	(mapcar	(FUNCTION (LAMBDA (i) (vla-Highlight i :vlax-true)))
		list_blocks
	)				;Подсвечиваем выбранные блоки


	(mapcar	(FUNCTION APEL-DELETE)
		(apply 'append (mapcar 'cadr list_SS))
	)				;Удаляем объекты из найденных выборок


      )

    (princ (strcat "\n Создано блоков: "
		   (rtos (LENGTH list_blocks) 2 0)
	   )
    )
    (princ "\n Не получилось!")
  )
)