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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Задача по выбору блока, который пересекается с линией определенной длины и цвета

Задача по выбору блока, который пересекается с линией определенной длины и цвета

Ответ
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 05.04.2019, 08:39 #1
Задача по выбору блока, который пересекается с линией определенной длины и цвета
aafeoktistov
 
Регистрация: 26.02.2019
Сообщений: 49
Здравствуйте! Это идейное продолжение темы

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

Суть вопроса вот в чём. Можно ли через ssget (или другую функцию) задать выбор линии определенного цвета и главное длины ОДНОВРЕМЕННО.

Или же единственный вариант это добавить в набор через ssget ВСЕ линии черного цвета, а потом через ssdel исключить из него все линии, которые НЕ 3.3 длиной.

Надеюсь кто то поможет связать все это воедино.

П.С. на всякий случай прикладываю рабочий LISP, который выбирает блок, находящийся на линии определенного цвета, но при этом исключает выбор если блок расположен на пересечении линий разного цвета.

П.П.С. Если заменить exclude_line_color на exclude_line_length это что то даст?

Код:
[Выделить все] 
  (defun c:CHCL10 ( / block_sset in_blocks_found_list ex_blocks_found_list
				  include_line_color exclude_line_color block_name
				  in_ex_lines_ss in_ex_lines_list
				  in_blocks_found_ss in_blocks_list
			  )
	(setq blocks_sset (ssadd)
		  in_ex_lines_list '()
		  in_blocks_found_list '()
		  ex_blocks_found_list '()
		  include_line_color 7  ;white
		  exclude_line_color 30 ;orange
		  block_name "Имя блока"
	)
	(cond
		(
			(null (cadr (ssgetfirst)))
		  		(setq in_ex_lines_ss (ssget (list (cons 0 "LINE") (cons -4 "<or") (cons 62 include_line_color) (cons 62 exclude_line_color) (cons -4 "or>"))))
				(if in_ex_lines_ss (setq in_ex_lines_list (vl-remove-if '(lambda (list_member) (/= 'ename (type list_member))) (mapcar 'cadr (ssnamex in_ex_lines_ss)))))
		)
		(
			t
				(setq in_ex_lines_ss (cadr (ssgetfirst))
					  in_ex_lines_list (vl-remove-if '(lambda (list_member)
																		(or
																			(/= 'ename (type list_member))
																			(not
																				(and
																					(= "LINE" (cdr (assoc 0 (entget list_member))))
																					(or
																						(= include_line_color (cdr (assoc 62 (entget list_member))))
																						(= exclude_line_color (cdr (assoc 62 (entget list_member))))
																					)
																				)
																			)
																		)
														)
														(mapcar 'cadr (ssnamex in_ex_lines_ss))
										 )
				)
		)
	)
	(if in_ex_lines_list
		(progn
			(foreach line_entity in_ex_lines_list
				(setq in_blocks_found_ss (ssget "_f" (list
														(list
															  (car (vlax-get (vlax-ename->vla-object line_entity) 'startpoint))
															  (cadr (vlax-get (vlax-ename->vla-object line_entity) 'startpoint))
														)
														(list
															  (car (vlax-get (vlax-ename->vla-object line_entity) 'endpoint))
															  (cadr (vlax-get (vlax-ename->vla-object line_entity) 'endpoint))
														)
												  )
												  (list (cons 0 "INSERT"))
									  )
				)
				(if in_blocks_found_ss
					(progn
						(setq in_blocks_list (mapcar 'cadr (ssnamex in_blocks_found_ss)))
						(foreach block_entity in_blocks_list
							(if (= block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
								(if (= include_line_color (cdr (assoc 62 (entget line_entity))))
									(setq in_blocks_found_list (cons block_entity in_blocks_found_list))
									(setq ex_blocks_found_list (cons block_entity ex_blocks_found_list))
								)
							)
						)
					)
				)
			)
			(foreach exclude_member ex_blocks_found_list 
				(setq in_blocks_found_list 
					(vl-remove-if '(lambda (in_blocks_found_list_member) 
										(equal exclude_member in_blocks_found_list_member)
								   ) 
								   in_blocks_found_list
					)
				)
			)
			(foreach block_entity in_blocks_found_list (setq blocks_sset (ssadd block_entity blocks_sset)))
			(princ (strcat "\nВыбрано блоков \"" block_name "\": " (itoa (sslength blocks_sset))))
			(sssetfirst nil blocks_sset)
			(setq blocks_sset nil)
		)
		(princ (strcat "\nвыбрано блоков \"" block_name "\": 0"))
	)
	(princ)
)
Последний раз редактировалось aafeoktistov, 08.04.2019 в 09:19.
Просмотров: 2698
 
Непрочитано 05.04.2019, 08:52
#2
trir


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

задачка на один SQL-запрос
trir вне форума  
 
Автор темы   Непрочитано 05.04.2019, 08:58
#3
aafeoktistov


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

Цитата:
Сообщение от trir Посмотреть сообщение
задачка на один SQL-запрос
А можно поподробнее? Точнее хотелось бы реализовать задачу через LISP, и заодно выяснить возможные варианты
aafeoktistov вне форума  
 
Непрочитано 05.04.2019, 09:32
#4
trir


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

Код:
[Выделить все] 
select id_line, id_point
from lines, points
where geom_line.STIntersects(points)=1 and color_line=7 and geom_line.STLength () = 7.0
только данные надо предварительно загрузить в БД
trir вне форума  
 
Автор темы   Непрочитано 05.04.2019, 09:34
#5
aafeoktistov


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

Цитата:
Сообщение от trir Посмотреть сообщение
Код:
[Выделить все] 
select id_line, id_point
from lines, points
where geom_line.STIntersects(points)=1 and color_line=7 and geom_line.STLength () = 7.0
только данные надо прекдварительно загрузить в БД
А это как то можно использовать в лиспе?
aafeoktistov вне форума  
 
Непрочитано 05.04.2019, 09:35
#6
trir


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

нет, но если использовать БД - lisp и не нужен, там задача решается гораздо проще
trir вне форума  
 
Непрочитано 05.04.2019, 09:39
#7
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,679

Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
П.С. на всякий случай прикладываю рабочий LISP, который выбирает блок, находящийся на линии определенного цвета, но при этом исключает выбор если блок расположен на пересечении линий разного цвета.

П.П.С. Если заменить exclude_line_color на exclude_line_length это что то даст?
aafeoktistov, не надо заниматься гаданием - это не тема спиритического сеанса. как минимум нужно понимать алгоритм + какое-то осмысление лиспа
ssget с длиной отрезка никак не поможет.

Код:
[Выделить все] 
 (defun c:chcl ()
	(setq blocks_sset (ssadd)
	      seek_block_line_color 7 ;white
		  seek_block_line_length 3.3
	      seek_block_name "Имя блока"
	)
	(cond
	    (
	        (null (cadr (ssgetfirst)))
	            (setq seek_lines_ss (ssget (list (cons 0 "LINE") (cons 62 seek_block_line_color))))
	    )
	    (
	        t
	            (setq seek_lines_ss (cadr (ssgetfirst)))
	    )
	)
	(if seek_lines_ss
		(progn
			(while (not (zerop (sslength seek_lines_ss)))
				(if (= "LINE" (cdr (assoc 0 (entget (ssname seek_lines_ss 0)))))
	    	    	(if (setq blocks_found_ss (ssget "_f" (list
	    	    	                                      	(vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'startpoint)
	    	    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'endpoint)
	    	    	                                  	  )
	    	    	                                  	  (list (cons 0 "INSERT"))
	    	    	    				  	  )
						)
	    	    	    (progn
	    	    	        (setq blocks_found_list (mapcar 'cadr (ssnamex blocks_found_ss)))
	    	    	        (if blocks_found_list
	    	    	            (foreach block_entity blocks_found_list
	    	    	                (if (and
											(= seek_block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
											(equal seek_block_line_length (vla-get-length (vlax-ename->vla-object (ssname seek_lines_ss 0))) 1e-4)
										)
	    	    	                    (setq blocks_sset (ssadd block_entity blocks_sset))
	    	    	                )
	    	    	            )
	    	    	        )
	    	    	    )
					)
				)
				(setq seek_lines_ss (ssdel (ssname seek_lines_ss 0) seek_lines_ss))
			)
			(sssetfirst nil blocks_sset)
		)
	)
	(princ)
)
koMon вне форума  
 
Автор темы   Непрочитано 05.04.2019, 09:47
#8
aafeoktistov


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

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

т.е. я задаю свойства include_line_color и include_line_length (цвет и длину) а потом через cons объединяю их и проверяю все блоки на пересечения с линиями конкретной длины и цвета...

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

Код:
[Выделить все] 
 (defun c:CHCL10 ( / block_sset in_blocks_found_list ex_blocks_found_list
				  include_line_color include_line_length block_name
				  in_ex_lines_ss in_ex_lines_list
				  in_blocks_found_ss in_blocks_list
			  )
	(setq blocks_sset (ssadd)
		  in_ex_lines_list '()
		  in_blocks_found_list '()
		  ex_blocks_found_list '()
		  include_line_color 7  ;white
		  include_line_length 3.3 ;length
		  block_name "Имя_блока"
	)
	(cond
		(
			(null (cadr (ssgetfirst)))
		  		(setq in_ex_lines_ss (ssget (list (cons 0 "LINE") (cons -4 "<and") (cons 62 include_line_color) (cons 2 include_line_length) (cons -4 "and>"))))
				(if in_ex_lines_ss (setq in_ex_lines_list (vl-remove-if '(lambda (list_member) (/= 'ename (type list_member))) (mapcar 'cadr (ssnamex in_ex_lines_ss)))))
		)
		(
			t
				(setq in_ex_lines_ss (cadr (ssgetfirst))
					  in_ex_lines_list (vl-remove-if '(lambda (list_member)
																		(or
																			(/= 'ename (type list_member))
																			(not
																				(and
																					(= "LINE" (cdr (assoc 0 (entget list_member))))
																					(or
																						(= include_line_color (cdr (assoc 62 (entget list_member))))
																						(= include_line_length (cdr (assoc 2 (entget list_member))))
																					)
																				)
																			)
																		)
														)
														(mapcar 'cadr (ssnamex in_ex_lines_ss))
										 )
				)
		)
	)
	(if in_ex_lines_list
		(progn
			(foreach line_entity in_ex_lines_list
				(setq in_blocks_found_ss (ssget "_f" (list
														(list
															  (car (vlax-get (vlax-ename->vla-object line_entity) 'startpoint))
															  (cadr (vlax-get (vlax-ename->vla-object line_entity) 'startpoint))
														)
														(list
															  (car (vlax-get (vlax-ename->vla-object line_entity) 'endpoint))
															  (cadr (vlax-get (vlax-ename->vla-object line_entity) 'endpoint))
														)
												  )
												  (list (cons 0 "INSERT"))
									  )
				)
				(if in_blocks_found_ss
					(progn
						(setq in_blocks_list (mapcar 'cadr (ssnamex in_blocks_found_ss)))
						(foreach block_entity in_blocks_list
							(if (= block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
								(if (= include_line_color (cdr (assoc 62 (entget line_entity))))
									(setq in_blocks_found_list (cons block_entity in_blocks_found_list))
									(setq ex_blocks_found_list (cons block_entity ex_blocks_found_list))
								)
							)
						)
					)
				)
			)
			(foreach exclude_member ex_blocks_found_list 
				(setq in_blocks_found_list 
					(vl-remove-if '(lambda (in_blocks_found_list_member) 
										(equal exclude_member in_blocks_found_list_member)
								   ) 
								   in_blocks_found_list
					)
				)
			)
			(foreach block_entity in_blocks_found_list (setq blocks_sset (ssadd block_entity blocks_sset)))
			(princ (strcat "\nВыбрано блоков \"" block_name "\": " (itoa (sslength blocks_sset))))
			(sssetfirst nil blocks_sset)
			(setq blocks_sset nil)
		)
		(princ (strcat "\nвыбрано блоков \"" block_name "\": 0"))
	)
	(princ)
)
П.С. С названием темы получается небольшое расхождения, однако если я правильно понял то через SSGET нельзя получить набор одновременно с 2 свойствами, а именно цвет и длина отрезка (LINE), к примеру...

----- добавлено через ~4 мин. -----
Цитата:
Сообщение от koMon Посмотреть сообщение
aafeoktistov, не надо заниматься гаданием - это не тема спиритического сеанса. как минимум нужно понимать алгоритм + какое-то осмысление лиспа
ssget с длиной отрезка никак не поможет.

Код:
[Выделить все] 
 (defun c:chcl ()
	(setq blocks_sset (ssadd)
	      seek_block_line_color 7 ;white
		  seek_block_line_length 3.3
	      seek_block_name "Имя блока"
	)
	(cond
	    (
	        (null (cadr (ssgetfirst)))
	            (setq seek_lines_ss (ssget (list (cons 0 "LINE") (cons 62 seek_block_line_color))))
	    )
	    (
	        t
	            (setq seek_lines_ss (cadr (ssgetfirst)))
	    )
	)
	(if seek_lines_ss
		(progn
			(while (not (zerop (sslength seek_lines_ss)))
				(if (= "LINE" (cdr (assoc 0 (entget (ssname seek_lines_ss 0)))))
	    	    	(if (setq blocks_found_ss (ssget "_f" (list
	    	    	                                      	(vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'startpoint)
	    	    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'endpoint)
	    	    	                                  	  )
	    	    	                                  	  (list (cons 0 "INSERT"))
	    	    	    				  	  )
						)
	    	    	    (progn
	    	    	        (setq blocks_found_list (mapcar 'cadr (ssnamex blocks_found_ss)))
	    	    	        (if blocks_found_list
	    	    	            (foreach block_entity blocks_found_list
	    	    	                (if (and
											(= seek_block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
											(equal seek_block_line_length (vla-get-length (vlax-ename->vla-object (ssname seek_lines_ss 0))) 1e-4)
										)
	    	    	                    (setq blocks_sset (ssadd block_entity blocks_sset))
	    	    	                )
	    	    	            )
	    	    	        )
	    	    	    )
					)
				)
				(setq seek_lines_ss (ssdel (ssname seek_lines_ss 0) seek_lines_ss))
			)
			(sssetfirst nil blocks_sset)
		)
	)
	(princ)
)
Спасибо что откликнулись!!! Я в будущем планирую засесть за изучение LISP просто сейчас надо решать конкретные задачи(((( поэтому вынужден обращаться за помощью. Вам опять же большое спасибо что помогаете "чайникам"

П.С. интересно а то что я исправил в вашем лиспе из другой темы вообще должно работать? (хотя проверил вроде работает). Если не тяжело напишите что там лишнего)

----- добавлено через ~15 мин. -----
Цитата:
Сообщение от koMon Посмотреть сообщение
aafeoktistov, не надо заниматься гаданием - это не тема спиритического сеанса. как минимум нужно понимать алгоритм + какое-то осмысление лиспа
ssget с длиной отрезка никак не поможет.

Код:
[Выделить все] 
 (defun c:chcl ()
	(setq blocks_sset (ssadd)
	      seek_block_line_color 7 ;white
		  seek_block_line_length 3.3
	      seek_block_name "Имя блока"
	)
	(cond
	    (
	        (null (cadr (ssgetfirst)))
	            (setq seek_lines_ss (ssget (list (cons 0 "LINE") (cons 62 seek_block_line_color))))
	    )
	    (
	        t
	            (setq seek_lines_ss (cadr (ssgetfirst)))
	    )
	)
	(if seek_lines_ss
		(progn
			(while (not (zerop (sslength seek_lines_ss)))
				(if (= "LINE" (cdr (assoc 0 (entget (ssname seek_lines_ss 0)))))
	    	    	(if (setq blocks_found_ss (ssget "_f" (list
	    	    	                                      	(vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'startpoint)
	    	    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'endpoint)
	    	    	                                  	  )
	    	    	                                  	  (list (cons 0 "INSERT"))
	    	    	    				  	  )
						)
	    	    	    (progn
	    	    	        (setq blocks_found_list (mapcar 'cadr (ssnamex blocks_found_ss)))
	    	    	        (if blocks_found_list
	    	    	            (foreach block_entity blocks_found_list
	    	    	                (if (and
											(= seek_block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
											(equal seek_block_line_length (vla-get-length (vlax-ename->vla-object (ssname seek_lines_ss 0))) 1e-4)
										)
	    	    	                    (setq blocks_sset (ssadd block_entity blocks_sset))
	    	    	                )
	    	    	            )
	    	    	        )
	    	    	    )
					)
				)
				(setq seek_lines_ss (ssdel (ssname seek_lines_ss 0) seek_lines_ss))
			)
			(sssetfirst nil blocks_sset)
		)
	)
	(princ)
)
Почему то выбираются все блоки не зависимо от цвета и длины линии...

----- добавлено через ~4 ч. -----
Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
Почему то выбираются все блоки не зависимо от цвета и длины линии...
KoMon подскажите пожалуйста, а разве там про длин линии не в блоках написано? Как вы уже сказали я не понимаю в структуре, но я имел ввиду что блок находится на пересечении с отрезком длиной 3.3



Помогите, я уже немогу думать ни о чем другом, хочу решить этот вопрос
aafeoktistov вне форума  
 
Непрочитано 05.04.2019, 17:01
#9
Семёныч


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

Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
Можно ли через ssget (или другую функцию) задать выбор линии определенного цвета и главное длины ОДНОВРЕМЕННО.
Пример выбора линий цвета 7 и длиной 3.3:
Код:
[Выделить все] 
(defun C:CLL ( / ssl nssl lss vlss dl n pss)
(setq ssl (ssget (list (cons 62 7) (cons 0 "*LINE"))))
(setq nssl (sslength ssl) n 0 pss nil pss (ssadd))
(repeat nssl
        (setq lss (ssname ssl n))
        (setq vlss (vlax-ename->vla-object lss))
        (if (vlax-property-available-p vlss 'Length)
            (progn
            (setq dl (vlax-get-property vlss 'Length))
            (princ "\n ") (prin1 dl)
            (if (= (atof (rtos dl 2 1)) 3.3) (ssadd lss pss))
            ) ; progn
        ) ; if
        (setq n (+ n 1))
) ; repeat
(if pss (sssetfirst pss pss))
(princ)
)
Семёныч вне форума  
 
Непрочитано 05.04.2019, 18:02
#10
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,679

Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
Помогите, я уже немогу думать ни о чем другом, хочу решить этот вопрос
хм, должен выбирать блоки пересекаемые отрезками (7) длиной 3.3
koMon вне форума  
 
Автор темы   Непрочитано 05.04.2019, 18:14
#11
aafeoktistov


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

Цитата:
Сообщение от koMon Посмотреть сообщение
хм, должен выбирать блоки пересекаемые отрезками (7) длиной 3.3
Я попробовал вписать функции вначале, не получилось... Если будет время, посмотрите плз, приложил файл для теста...
Вложения
Тип файла: dwg
DWG 2013		 Для_теста.dwg (385.9 Кб, 5 просмотров)
aafeoktistov вне форума  
 
Непрочитано 05.04.2019, 19:52
#12
Семёныч


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

Простая программа для частной задачи выделения блоков, пересекаемых отрезком с цветом 7 и длиной 3.3:
Код:
[Выделить все] 
(defun C:CBL ( / esho ssl nssl lss vlss dl n pss lpss sp ep spb k spo lspo ssb)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ssl (ssget (list (cons 62 7) (cons 0 "LINE"))))
(setq nssl (sslength ssl) n 0 pss nil pss (ssadd))
(repeat nssl
        (setq lss (ssname ssl n))
        (setq vlss (vlax-ename->vla-object lss))
        (setq dl (vlax-get-property vlss 'Length))
        (if (= (atof (rtos dl 2 1)) 3.3) (ssadd lss pss))
        (setq n (+ n 1))
) ; repeat
(if pss
    (progn
    (setq lpss (sslength pss) n 0 spb nil spb (ssadd))
    (repeat lpss
            (setq lss (ssname pss n))
            (setq sp (cdr (assoc 10 (entget lss))))
            (setq ep (cdr (assoc 11 (entget lss))))
            (vl-cmdf "_SELECT" "_f" sp ep "" "")
            (setq spo (ssget "_p"))
            (setq lspo (sslength spo) k 0)
            (repeat lspo
                    (setq ssb (ssname spo k))
                    (if (= (cdr (assoc 0 (entget ssb))) "INSERT")
                        (setq spb (ssadd ssb spb))
                    )
                    (setq k (+ k 1))
                ) ; repeat
            (setq n (+ n 1))
    ) ; repeat
    ) ; progn
) ; if
(if spb (progn (sssetfirst spb spb) (princ "\nВсего блоков = ") (princ (sslength spb))))
(setvar "CMDECHO" echo)
(princ)
)
Семёныч вне форума  
 
Автор темы   Непрочитано 06.04.2019, 06:56
#13
aafeoktistov


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

Цитата:
Сообщение от Семёныч Посмотреть сообщение
Простая программа для частной задачи выделения блоков, пересекаемых отрезком с цветом 7 и длиной 3.3:
Код:
[Выделить все] 
(defun C:CBL ( / esho ssl nssl lss vlss dl n pss lpss sp ep spb k spo lspo ssb)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ssl (ssget (list (cons 62 7) (cons 0 "LINE"))))
(setq nssl (sslength ssl) n 0 pss nil pss (ssadd))
(repeat nssl
        (setq lss (ssname ssl n))
        (setq vlss (vlax-ename->vla-object lss))
        (setq dl (vlax-get-property vlss 'Length))
        (if (= (atof (rtos dl 2 1)) 3.3) (ssadd lss pss))
        (setq n (+ n 1))
) ; repeat
(if pss
    (progn
    (setq lpss (sslength pss) n 0 spb nil spb (ssadd))
    (repeat lpss
            (setq lss (ssname pss n))
            (setq sp (cdr (assoc 10 (entget lss))))
            (setq ep (cdr (assoc 11 (entget lss))))
            (vl-cmdf "_SELECT" "_f" sp ep "" "")
            (setq spo (ssget "_p"))
            (setq lspo (sslength spo) k 0)
            (repeat lspo
                    (setq ssb (ssname spo k))
                    (if (= (cdr (assoc 0 (entget ssb))) "INSERT")
                        (setq spb (ssadd ssb spb))
                    )
                    (setq k (+ k 1))
                ) ; repeat
            (setq n (+ n 1))
    ) ; repeat
    ) ; progn
) ; if
(if spb (progn (sssetfirst spb spb) (princ "\nВсего блоков = ") (princ (sslength spb))))
(setvar "CMDECHO" echo)
(princ)
)
Спасибо большое, попробую! А можно туда как то включить запись конкретного блока?

----- добавлено через ~1 ч. -----
П.С. Потестил все работает!
aafeoktistov вне форума  
 
Непрочитано 06.04.2019, 10:19
#14
Семёныч


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

Код:
[Выделить все] 
;;; Частная задача выделения блоков с заданным именем или указанных на чертеже, которые пересекают
;;; отрезки с заданным цветом и фиксированной длиной 3.3 единицы.

(defun C:CBL ( / esho n-blk obj ent nc ssl nssl lss vlss dl n pss lpss sp ep spb k spo lspo ssb)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq n-blk (getstring T "\nИмя блока или Указать [У] (Enter-Любой): "))
(if (= n-blk "") (setq n-blk nil))
(if (= n-blk "У")
    (progn
    (setq obj (entsel "\nВыберите блок: "))
    (if (and obj (= (cdr (assoc 0 (entget (car obj)))) "INSERT"))
        (progn
        (setq ent (car obj))
        (setq n-blk (vlax-get-property (vlax-ename->vla-object ent) 'EffectiveName))
        ) ; progn
       (princ "\nЭто не блок.")
    ) ; if  
    ) ; progn
) ; if
(princ "\nИмя блока: ") (if n-blk (prin1 n-blk) (princ "Не задан"))
(initget 6)
(setq nc (getint "\nНомер цвета пересекающего отрезка <7>: "))
(if (= nc nil) (setq nc 7))
(princ "\nВыбор объектов стандартными способами (Enter-Отмена).")
(setq ssl (ssget (list (cons 62 nc) (cons 0 "LINE"))))
(IF ssl
(PROGN
(setq nssl (sslength ssl) n 0 pss nil pss (ssadd))
(repeat nssl
        (setq lss (ssname ssl n))
        (setq vlss (vlax-ename->vla-object lss))
        (setq dl (vlax-get-property vlss 'Length))
        (if (= (atof (rtos dl 2 1)) 3.3) (ssadd lss pss))
        (setq n (+ n 1))
) ; repeat
(if pss
    (progn
    (setq lpss (sslength pss) n 0 spb nil spb (ssadd))
    (repeat lpss
            (setq lss (ssname pss n))
            (setq sp (cdr (assoc 10 (entget lss))))
            (setq ep (cdr (assoc 11 (entget lss))))
            (vl-cmdf "_SELECT" "_f" sp ep "" "")
            (setq spo (ssget "_p"))
            (setq lspo (sslength spo) k 0)
            (repeat lspo
                    (setq ssb (ssname spo k))
                    (if n-blk 
                        (progn
                        (if (and 
                            (= (cdr (assoc 0 (entget ssb))) "INSERT")
                            (= (vlax-get-property (vlax-ename->vla-object ssb) 'EffectiveName) n-blk)
                            ) ; and
                            (setq spb (ssadd ssb spb))
                         ) ; if
                         ) ; progn
                         (if (= (cdr (assoc 0 (entget ssb))) "INSERT") (setq spb (ssadd ssb spb)))
                   ) ; if
            (setq k (+ k 1))
            ) ; repeat
            (setq n (+ n 1))
    ) ; repeat
    ) ; progn
) ; if
(if spb (progn (sssetfirst spb spb) (princ "\nВсего блоков = ") (princ (sslength spb))))
) ; PROGN
) ; IF
(setvar "CMDECHO" echo)
(princ)
)
Тему для определённости желательно переименовать.
Последний раз редактировалось Семёныч, 06.04.2019 в 10:27.
Семёныч вне форума  
 
Автор темы   Непрочитано 06.04.2019, 14:14
#15
aafeoktistov


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

Цитата:
Сообщение от Семёныч Посмотреть сообщение
Код:
[Выделить все] 
;;; Частная задача выделения блоков с заданным именем или указанных на чертеже, которые пересекают
;;; отрезки с заданным цветом и фиксированной длиной 3.3 единицы.

(defun C:CBL ( / esho n-blk obj ent nc ssl nssl lss vlss dl n pss lpss sp ep spb k spo lspo ssb)
(setq echo (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq n-blk (getstring T "\nИмя блока или Указать [У] (Enter-Любой): "))
(if (= n-blk "") (setq n-blk nil))
(if (= n-blk "У")
    (progn
    (setq obj (entsel "\nВыберите блок: "))
    (if (and obj (= (cdr (assoc 0 (entget (car obj)))) "INSERT"))
        (progn
        (setq ent (car obj))
        (setq n-blk (vlax-get-property (vlax-ename->vla-object ent) 'EffectiveName))
        ) ; progn
       (princ "\nЭто не блок.")
    ) ; if  
    ) ; progn
) ; if
(princ "\nИмя блока: ") (if n-blk (prin1 n-blk) (princ "Не задан"))
(initget 6)
(setq nc (getint "\nНомер цвета пересекающего отрезка <7>: "))
(if (= nc nil) (setq nc 7))
(princ "\nВыбор объектов стандартными способами (Enter-Отмена).")
(setq ssl (ssget (list (cons 62 nc) (cons 0 "LINE"))))
(IF ssl
(PROGN
(setq nssl (sslength ssl) n 0 pss nil pss (ssadd))
(repeat nssl
        (setq lss (ssname ssl n))
        (setq vlss (vlax-ename->vla-object lss))
        (setq dl (vlax-get-property vlss 'Length))
        (if (= (atof (rtos dl 2 1)) 3.3) (ssadd lss pss))
        (setq n (+ n 1))
) ; repeat
(if pss
    (progn
    (setq lpss (sslength pss) n 0 spb nil spb (ssadd))
    (repeat lpss
            (setq lss (ssname pss n))
            (setq sp (cdr (assoc 10 (entget lss))))
            (setq ep (cdr (assoc 11 (entget lss))))
            (vl-cmdf "_SELECT" "_f" sp ep "" "")
            (setq spo (ssget "_p"))
            (setq lspo (sslength spo) k 0)
            (repeat lspo
                    (setq ssb (ssname spo k))
                    (if n-blk 
                        (progn
                        (if (and 
                            (= (cdr (assoc 0 (entget ssb))) "INSERT")
                            (= (vlax-get-property (vlax-ename->vla-object ssb) 'EffectiveName) n-blk)
                            ) ; and
                            (setq spb (ssadd ssb spb))
                         ) ; if
                         ) ; progn
                         (if (= (cdr (assoc 0 (entget ssb))) "INSERT") (setq spb (ssadd ssb spb)))
                   ) ; if
            (setq k (+ k 1))
            ) ; repeat
            (setq n (+ n 1))
    ) ; repeat
    ) ; progn
) ; if
(if spb (progn (sssetfirst spb spb) (princ "\nВсего блоков = ") (princ (sslength spb))))
) ; PROGN
) ; IF
(setvar "CMDECHO" echo)
(princ)
)
Тему для определённости желательно переименовать.
Большое Вам человеческое спасибо! Я бы переименовал но к сожалению не знаю как...
aafeoktistov вне форума  
 
Непрочитано 06.04.2019, 14:49
#16
Кулик Алексей aka kpblc
Moderator

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

Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
Я бы переименовал но к сожалению не знаю как...
Как переименовать тему?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 08.04.2019, 09:19
#17
aafeoktistov


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

Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
Спасибо! Переименовал.
aafeoktistov вне форума  
 
Непрочитано 08.04.2019, 09:26
#18
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,679

Цитата:
Сообщение от aafeoktistov Посмотреть сообщение
Если будет время, посмотрите плз, приложил файл для теста...
проверил. был косяк при предварительно выбранных примитивах не хватало условия проверки цвета линии.
Код:
[Выделить все] 
 
(defun c:chcl_2 ()
    (setq blocks_sset (ssadd)
          seek_block_line_color 7 ;white
          seek_block_line_length 3.3
          seek_block_name "Контроль методом МПМ св.шва"
    )
    (cond
        (
            (null (cadr (ssgetfirst)))
                (setq seek_lines_ss (ssget (list (cons 0 "LINE") (cons 62 seek_block_line_color))))
        )
        (
            t
                (setq seek_lines_ss (cadr (ssgetfirst)))
        )
    )
;	(setq start_time (getvar 'millisecs))
    (if seek_lines_ss
        (progn
            (while (not (zerop (sslength seek_lines_ss)))
                (if (and (= "LINE" (cdr (assoc 0 (entget (ssname seek_lines_ss 0)))))
						 (= seek_block_line_color (cdr (assoc 62 (entget (ssname seek_lines_ss 0)))))
					)
                    	(if (setq blocks_found_ss (ssget "_f" (list
                    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'startpoint)
                    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'endpoint)
                    	                                      )
                    	                                      (list (cons 0 "INSERT"))
                    	                          )
                    	    )
                    	    (progn
                    	        (setq blocks_found_list (mapcar 'cadr (ssnamex blocks_found_ss)))
                    	        (if blocks_found_list
                    	            (foreach block_entity blocks_found_list
                    	                (if (and
                    	                        (= seek_block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
                    	                        (equal seek_block_line_length (vla-get-length (vlax-ename->vla-object (ssname seek_lines_ss 0))) 1e-4)
                    	                    )
                    	                    (setq blocks_sset (ssadd block_entity blocks_sset))
                    	                )
                    	            )
                    	        )
                    	    )
                    	)
                )
                (setq seek_lines_ss (ssdel (ssname seek_lines_ss 0) seek_lines_ss))
            )
            (sssetfirst nil blocks_sset)
        )
    )
;	(setq end_time (getvar 'millisecs))
;	(print (/ (- end_time start_time) 1000.0))
    (princ)
)
koMon вне форума  
 
Автор темы   Непрочитано 08.04.2019, 16:42
#19
aafeoktistov


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

Цитата:
Сообщение от koMon Посмотреть сообщение
проверил. был косяк при предварительно выбранных примитивах не хватало условия проверки цвета линии.
Код:
[Выделить все] 
 
(defun c:chcl_2 ()
    (setq blocks_sset (ssadd)
          seek_block_line_color 7 ;white
          seek_block_line_length 3.3
          seek_block_name "Контроль методом МПМ св.шва"
    )
    (cond
        (
            (null (cadr (ssgetfirst)))
                (setq seek_lines_ss (ssget (list (cons 0 "LINE") (cons 62 seek_block_line_color))))
        )
        (
            t
                (setq seek_lines_ss (cadr (ssgetfirst)))
        )
    )
;	(setq start_time (getvar 'millisecs))
    (if seek_lines_ss
        (progn
            (while (not (zerop (sslength seek_lines_ss)))
                (if (and (= "LINE" (cdr (assoc 0 (entget (ssname seek_lines_ss 0)))))
						 (= seek_block_line_color (cdr (assoc 62 (entget (ssname seek_lines_ss 0)))))
					)
                    	(if (setq blocks_found_ss (ssget "_f" (list
                    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'startpoint)
                    	                                        (vlax-get (vlax-ename->vla-object (ssname seek_lines_ss 0)) 'endpoint)
                    	                                      )
                    	                                      (list (cons 0 "INSERT"))
                    	                          )
                    	    )
                    	    (progn
                    	        (setq blocks_found_list (mapcar 'cadr (ssnamex blocks_found_ss)))
                    	        (if blocks_found_list
                    	            (foreach block_entity blocks_found_list
                    	                (if (and
                    	                        (= seek_block_name (vla-get-effectivename (vlax-ename->vla-object block_entity)))
                    	                        (equal seek_block_line_length (vla-get-length (vlax-ename->vla-object (ssname seek_lines_ss 0))) 1e-4)
                    	                    )
                    	                    (setq blocks_sset (ssadd block_entity blocks_sset))
                    	                )
                    	            )
                    	        )
                    	    )
                    	)
                )
                (setq seek_lines_ss (ssdel (ssname seek_lines_ss 0) seek_lines_ss))
            )
            (sssetfirst nil blocks_sset)
        )
    )
;	(setq end_time (getvar 'millisecs))
;	(print (/ (- end_time start_time) 1000.0))
    (princ)
)
Большое спасибо! Протестирую!
aafeoktistov вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Задача по выбору блока, который пересекается с линией определенной длины и цвета

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Как убрать проблему в Автокаде 2012 при черчении на Листе линии стают визуально толще чем на самом деле. Leeds.un AutoCAD 8 11.11.2015 12:10
Нужна функция в Автокаде для преобразования линии в прямоугольник KEO Программирование 4 13.03.2015 16:03
Revit 2015. Невидимые линии стены в плане. Не могу отобразить. m03g0ed Revit 2 17.01.2015 14:09
Фильтры ssget: Можно ли выбрать все линии с одинаковыми начальной и конечной точками gomer Программирование 5 13.09.2010 08:40
Как в автокаде можно соеденить два премитива Line в один и цельный тоже Line dextron3 AutoCAD 15 30.10.2009 14:35

Обратная связь - Вверх