[WeMaN]

Собственно говоря имеется лисп который делает своеобразную проверку топологии:

Код:

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

(vl-load-com)
(defun sstolist (ss / i lst)
(setq i 0)
(repeat (sslength ss)
(setq lst (append lst (list (ssname ss i))) i (1+ i))
);end of repeat
lst
);end of sstolist

(defun c:topolog ( / ss ss1 lay flist i minpt maxpt lstbox)
(setq flist (list (cons -4 "<OR") (cons 0 "INSERT") (cons 0 "TEXT") (cons 0 "MTEXT") (cons -4 "OR>"))	
ss (ssget "_x" flist)
);end of setq
(if ss
(progn
(setq lay "Topolog" i 1)
(while  (tblsearch "layer" (strcat lay (itoa i)))
(setq i (1+ i))
);end of while
(setq lay (strcat lay (itoa i)) ss (sstolist ss) i 0)
(foreach obj ss
(vla-GetBoundingBox (vlax-ename->vla-object obj) 'minpt 'maxpt)
(setq 	minpt (vlax-safearray->list minpt) maxpt (vlax-safearray->list maxpt)
	lstbox (list minpt (list (car minpt) (cadr maxpt)) maxpt (list (car maxpt) (cadr minpt)))
	ss1 (ssget "_CP" lstbox flist)
);end of setq
(if ss1
(if (> (sslength ss1) 1)
(progn
(entmakex (append (list 
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 8 lay)
(cons 62 1)
);end of list
(mapcar '(lambda (x) (cons 10 x)) lstbox)
));end of entmakex & append
(setq i (1+ i))
);end of progn
));end of if * 2
);end of foreach
(if (= i 0)
(princ "\nПересечений не найдено")
(princ (strcat "\nНайдено " (itoa i) " пересечений, выделенных в слое " lay "." ))
)
);end of progn
(princ "\nОбъектов не найдено")
);end if
(princ)
);end of topolog

Данный алгоритм, как видно из скриншота выше, позволяет выделять полилинией объекты на топоплане, которые наползают друг на друга. прямоугольники кидаются в слой Topolog1 (2,3 и т.д.)
Собственно, меня интересует такой вопрос, можно ли научить алгоритм, или создать новый код, который бы распозновал именно блоки выделенные данной областью и перекидывал бы их на специальный слой. К примеру, из рисунка видно, что два кустарника наползают на текст, можно ли их переместить в другой слой (например распознать их как переносить блоки в слой "имяслоя" рядом с которым находятся полилинии из слоя Topolog).
В общем, надеюсь на помощь и советы. Может кто уже сталкивался с этим, и сможет подсказать решения.
ЗЫ
Ежели кто знает ещё какие нибудь программы проверяющие топологию в автокаде, буду очень признателен если поделитесь. Тема довольно актуальна

[Дима_]

(с) "Достаточно одной таблетки"

Код:

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

(defun sstolist (ss / i lst)
(setq i 0)
(repeat (sslength ss)
(setq lst (append lst (list (ssname ss i))) i (1+ i))
);end of repeat
lst
);end of sstolist

(defun c:topolog ( / ss ss1 lay flist i minpt maxpt lstbox)
(setq flist (list (cons -4 "<OR") (cons 0 "INSERT") (cons 0 "TEXT") (cons 0 "MTEXT") (cons -4 "OR>"))	
ss (ssget "_x" flist)
);end of setq
(if ss
(progn
(setq lay "Topolog" i 1)
(while  (tblsearch "layer" (strcat lay (itoa i)))
(setq i (1+ i))
);end of while
(setq lay (strcat lay (itoa i)) ss (sstolist ss) i 0)
(foreach obj ss
(vla-GetBoundingBox (vlax-ename->vla-object obj) 'minpt 'maxpt)
(setq 	minpt (vlax-safearray->list minpt) maxpt (vlax-safearray->list maxpt)
	lstbox (list minpt (list (car minpt) (cadr maxpt)) maxpt (list (car maxpt) (cadr minpt)))
	ss1 (ssget "_CP" lstbox flist)
);end of setq
(if ss1
(if (> (sslength ss1) 1)
(progn
(entmakex (append (list 
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 8 lay)
(cons 62 1)
);end of list
(mapcar '(lambda (x) (cons 10 x)) lstbox)
));end of entmakex & append
(mapcar '(lambda (x) (entmod (subst (cons 8 lay) (assoc 8 x) x))) (mapcar 'entget (sstolist ss1))); это таблетка
(setq i (1+ i))
);end of progn
));end of if * 2
);end of foreach
(if (= i 0)
(princ "\nПересечений не найдено")
(princ (strcat "\nНайдено " (itoa i) " пересечений, выделенных в слое " lay "." ))
)
);end of progn
(princ "\nОбъектов не найдено")
);end if
(princ)
);end of topolog

з.ы. - только сейчас понял - что это изначально мой лисп - мда.

[WeMaN]

Ну да, это же я когда-то в этой теме просил как раз совета. Вот, возникла так сказать новая идея по модернизации. Спасибо, что откликнулись, сейчас буду тестить.


Проверил, вроде работает, только вместе с блоками, затягивает в другой слой и текст. Можно ли чтобы он делал это только с блоками? И ещё вот такой вопрос, как обозначить слой, в который пойдут выделенные блоки, т.е. хочется допустим чтобы все линии так и оставались в Topolog, а блоки были не в Topolog, а в каком нить Na_Obrabotku например...

[Дима_]

замени выделенную строку на

Код:

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

(mapcar '(lambda (x) (entmod (subst (cons 8 "на обработку") (assoc 8 x) x))) 
(vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 x)) "INSERT")) (mapcar 'entget (sstolist ss1))))

без проверки - но по идее должно работать
на всякий случай добавь в начале 2-го лиспа 1-ой строкой "(vl-load-com)" - убежал при переносе из 1-го.

[WeMaN]

Спасибо за помощь, всё работает так как нужно!
А вот (vl-load-com) я так и не вставил, впринципе может вставить, несмотря на то что лисп и так работает? Он какие то серьёзные функции выполняет?

[Дима_]

его надо запусить 1 раз в начале сеанса - загрузка модуля visual-lisp - практически все команды vl-*, vla-*. Если не поставил - оно - работает - значит в этом сеансе кто-то уже запустил (предыдущий лисп, либо что-то в автозагрузке) - в общем рекомендую добавить.

[WeMaN]

Спасибо за помощь, очень помогли, давно эту замутку в уме держал, видать надо было спросить пораньше
А вот чтобы этот лисп в отдельный выделить модуль, код должен выглядеть так?

Код:

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

(vl-load-com)
(defun sstolist (ss / i lst)
(setq i 0)
(repeat (sslength ss)
(setq lst (append lst (list (ssname ss i))) i (1+ i))
);end of repeat
lst
);end of sstolist

(defun c:topolog ( / ss ss1 lay flist i minpt maxpt lstbox)
(setq flist (list (cons -4 "<OR") (cons 0 "INSERT") (cons 0 "TEXT") (cons 0 "MTEXT") (cons -4 "OR>"))	
ss (ssget "_x" flist)
);end of setq
(mapcar '(lambda (x) (entmod (subst (cons 8 "на обработку") (assoc 8 x) x))) 
(vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 x)) "INSERT")) (mapcar 'entget (sstolist ss1))))
);end of topolog

Хотя нет, сейчас проверил в AutoCad, выдает неверный тип аргумента: lselsetp nil
Где то видимо не дописал?

[Дима_]

Еслиб я понимал, что по твоему "отдельный модуль" я б, наверное, ответил.

[WeMaN]

НУ отдельно работающая программа, т.е. есть лисп который делает проверку, а есть который результат этой проверки пихает в слой

[Дима_]

Неправильно, проверка - это проверяет есть-ли пересекающиеся объекты, а выделение их рамкой, как и переброска на другой слой - это уже отдельное действие. Тебе надо лисп который перебрасывает блоки на слой "на обработку" ничего не выделяя? Удали выделенное курсивом из поста с программой (не забыв заменить таблетки на нужные).

[WeMaN]

Ок, но ведь таблетка и там та которая необходима в посте с кодом или нет?

[Дима_]

Смотри у тебя есть код (пост 2) - в нем жирным выделен фрагмент который переносит блоки и тексты на слой topologX, его можно безболезнено удалить (тогда он этого делать не будет), либо заменить на код из 4 поста (тогда он будет переносить на слой "на обработку" и только блоки), также есть выделенный курсивом - он создает прямоугольники в "проблемных" областях, его можно безболезненно удалить - соответственно прямоугольников не появится.

[WeMaN]

Спасибо за советы и помощь, разобрался, классная програмка получается ))
Кстати а можно по тому же принципу сделать проверку наползания текста не на блоки, а на полилинии?
Например, есть у нас условный знак болота в слое "Boloto", состоящии из горизонтально расположенных линий, и есть отметки высот, можно ли те линии которые наползли на отметку и блоки изолировать в другие слои?

[АлексЮстасу]

Сообщение от WeMaN Кстати а можно по тому же принципу сделать проверку наползания текста не на блоки, а на полилинии?

Присоединяюсь. Такая программа была бы очень нужна для причесывания файлов перед печатью и т.п. И наложения не только текста на полилинии, но и блоков на полилинии (и линии тоже).

[Sleekka]

Я таки понял что с примитивами типа INSERT - не тестировалось, ибо с ними должно работать не правильно. Там нужно конвертировать координаты из внутренней системы координат блоха в мировую, даже при использовании boundingbox

[АлексЮстасу]

Сообщение от Sleekka Я таки понял что с примитивами типа INSERT - не тестировалось, ибо с ними должно работать не правильно. Там нужно конвертировать координаты из внутренней системы координат блоха в мировую, даже при использовании boundingbox

1. что такое "примитивы типа INSERT"?
2. чувствуется, что есть какие-то хорошие предложения...

[Александр Ривилис]

Сообщение от АлексЮстасу 1. что такое "примитивы типа INSERT"?

Это вставки блока (то, что получается при выполнении команды _INSERT без расчленения блока).

[Do$]

Сообщение от Sleekka Я таки понял что с примитивами типа INSERT - не тестировалось, ибо с ними должно работать не правильно. Там нужно конвертировать координаты из внутренней системы координат блоха в мировую, даже при использовании boundingbox

Это если б обрабатывались примитивы внутри блока. Если применяется метод getboundingbox ко вставке блока (как и сделано в программе), то ничего не нужно конвертировать - координаты и так будут в WCS.

[АлексЮстасу]

Если с блоками ("типа INSERT") все нормально, то можно найти все места в файлах, где блоки (и подписи тоже) накладываются на линейные элементы?

[Sleekka]

Это если б обрабатывались примитивы внутри блока. Если применяется метод getboundingbox ко вставке блока (как и сделано в программе), то ничего не нужно конвертировать - координаты и так будут в WCS.

ну ну