Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → LISP → Поиск дублированных размеров
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Помогите с написанием lisp для поиска одинаковых размеров по их значению.
Одинаковых размеров может быть большое количество.
Мне нужен лисп который бы во всех одинаковых значениях размера, устанавливал цвет значения размера, например "синий", чтобы можно было их просмотреть и удалить лишние.
Спасибо! Буду рад за помощь...
Мужики... помогите с решением задачи!!!
Я проверяю чертежи и мне нужно решит эту задачку...
Кто знает lisp отзовитесь...
Низкий Вам поклон
Попробуй в командной строке команду:
"_OVERKILL"
_overkill, насколько я знаю не для этого.
Мне нужен лисп который бы осуществлял бы поиск одинаковых measure (значение) размера, например на чертеже 5 размеров со значениями 150, и изменял бы цвет значения одинаковых размеров на "синий"
Есть опытные, человеколюбивые профи по лиспу??? Очень нужно мужики...
Попробуй без особых поверок,
дубликаты измерений перекрашиваем в синий циет
увеличиваем и добавляем порядок отображения
;; inspired by MI_ChkDup.lsp
;; www.4d-technologies.com
(defun C:DELDUPDIMS ( / cnt dd dims dupdims dupes en endata entl matchlist pt10 pt11 pt12 pt13 pt14 pt15 pt16 ss)
(prompt "\nВыбор измерений в текущей вкладке")
(command "_undo" "_BE")
(if (setq ss (ssget "_X" (list (cons 0 "DIMENSION")(cons 410 (getvar "ctab")))))
(progn
(alert (strcat "Всего размеров: "(itoa (sslength ss))))
(setq dims (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
;;(setq matchlist nil)
(setq dupes (ssadd))
(setq en (car dims)
entl (entget en))
(setq endata (list
(setq pt10 (cdr (assoc 10 entl)))
(setq pt11 (cdr (assoc 11 entl)))
(setq pt12 (cdr (assoc 12 entl)))
(setq pt13 (cdr (assoc 13 entl)))
(setq pt14 (cdr (assoc 14 entl)))
(setq pt15 (cdr (assoc 15 entl)))
(setq pt16 (cdr (assoc 16 entl)))
(setq dd (cdr (assoc 42 entl)))
)
)
;;(ssadd en dupes)
(setq matchlist (append matchlist (list endata)))
(setq cnt 1)
(while
(setq en (nth cnt dims))
(setq entl (entget en))
(setq endata (list
(setq pt10 (cdr (assoc 10 entl)))
(setq pt11 (cdr (assoc 11 entl)))
(setq pt12 (cdr (assoc 12 entl)))
(setq pt13 (cdr (assoc 13 entl)))
(setq pt14 (cdr (assoc 14 entl)))
(setq pt15 (cdr (assoc 15 entl)))
(setq pt16 (cdr (assoc 16 entl)))
(setq dd (cdr (assoc 42 entl)))
)
)
(if (member endata matchlist)
(ssadd en dupes);(sslength dupes)
(setq matchlist (append matchlist (list endata)))
)
(setq cnt(1+ cnt)))))
(if (> (sslength dupes) 0)
(progn
(alert (strcat "Определено дубликатов размеров: "(itoa (sslength dupes))))
(setq dupdims (vl-remove-if 'listp (mapcar 'cadr (ssnamex dupes))))
(setq cnt 0)
(setvar "cmdecho" 0)
(while
(setq en (nth cnt dupdims))
(setq entl (entget en))
(command "_chprop" en "" "_P" "_COLOR" "5" "")
(command "_draworder" en "" "_F" )
(command "_scale" en "" (cdr (assoc 11 entl)) 1.1 "")
(setq cnt (1+ cnt)))
)
(alert "Дубликатов не найдено.")
)
(setvar "cmdecho" 1)
(command "_undo" "_END")
(princ)
)
(defun C:DDUP()(C:DELDUPDIMS)(princ))
(C:DDUP);; автозапускНекогда тестировать, пробуй опять
Вот что пишет
Команда: ; ошибка: синтаксическая ошибка
Вот что пишет
Команда: ; ошибка: синтаксическая ошибка
Очень информативно, - я буду догадываться на какой строчке?
[ПРОВЕРКА ТЕКСТА <Без имени-0> загружается... SELECTION]
.
; ошибка: слишком мало аргументов в SETQ: (SETQ SS "_X" (SSGET ( ... )))
слишком мало аргументов в SETQ: (SETQ SS "_X" (SSGET (LIST (CONS 0 "DIMENSION") (CONS 410 (GETVAR "ctab")))))
..
; Проверка завершен
; ошибка: слишком мало аргументов в SETQ: (SETQ SS "_X" (SSGET ( ... )))
Код исправил пробуй опять
Команда: _DELDUPDIMS
Выбор измерений в текущей вкладке_undo Текущие настройки: Авто = Вкл, Управление = Все, Объединить = Есть, Слой = Есть
Количество отменяемых операций или [Авто/Управление/Начало/Конец/Метка/Обратно] <1>: _BE
Команда: ; ошибка: неверный тип аргумента: lselsetp nil
Кароч ищи сам, мне не до этого у меня работает
можешь скинуть Ваш работающий лисп на фаилобменник, чтобы не копировать код с сайта
Раз 20 копировал код, одна ошибка: неверный тип аргумента: lselsetp nil
Может еще есть спецы, которые бы помогли с решением этой задачи??? :cry:
Fixo: спасибо. Хоть что-то у меня появилось для решения задачи... :oops:
Попробуй скопировать отсюда
https://dl.dropbox.com/u/18024145/DDUP.LSP
Вот, что написал:
Выбор измерений в текущей вкладке_undo Текущие настройки: Авто = Вкл, Управление = Все, Объединить = Есть, Слой = Есть
Количество отменяемых операций или [Авто/Управление/Начало/Конец/Метка/Обратно] <1>: _be
Команда: ; ошибка: неверный тип аргумента: lselsetp nil
Пробуй опять
https://dl.dropbox.com/u/18024145/DDUP.LSP
Вроде работает, только не находит одинаковые размеры. Я на чертеже поставил два одинаковых размера, но в масштабных стилях: значение у них одинаково.
Говорит, что дубликатов нет.
Извини я пас, нет времени разгребать все твои
установки, у меня находит
Мне нужен лисп который бы осуществлял бы поиск одинаковых measure (значение) размера, например на чертеже 5 размеров со значениями 150, и изменял бы цвет значения одинаковых размеров на "синий"
Хорошо, у тебя 5 размеров 150 ед., и ещё 3 размера 100 ед., а ещё 6 размеров 50 ед, и т.д. и что, их все сделать "синими"?
В принципе можно и все "синими". Конечно лучше бы чтобы они были разными цветами, но не думаю что это можно реализовать, поэтому и не спрашиваю. Мне бы хотя бы это довести до ума.
Конечно лучше бы чтобы они были разными цветами, но не думаю что это можно реализовать
можно
(defun c:equal_dim (/ all_dim car_list tmp eq_dim i b)
(setq all_dim
(mapcar 'entget
(vl-remove-if
'listp
(mapcar 'cadr
(ssnamex (ssget "_X" '((0 . "DIMENSION"))))
)
)
)
)
(while (car all_dim)
(setq car_list (cdr (assoc 42 (car all_dim)))
tmp (list
(vl-remove-if-not
(function (lambda (a)
(equal (cdr (assoc 42 a)) car_list 1e-12)
)
)
all_dim
)
)
eq_dim (cons (car tmp) eq_dim)
all_dim (vl-remove-if
(function (lambda (a)
(equal (cdr (assoc 42 a)) car_list 1e-12)
)
)
all_dim
)
tmp nil
)
)
(setq eq_dim (vl-remove-if
(function (lambda (x) (= (length x) 1)))
eq_dim
)
i 0
b (cond
((>= 6 (length eq_dim))
1
)
((>= 12 (length eq_dim))
20
)
((>= 24 (length eq_dim))
10
)
(t 1)
)
)
(cond
((not eq_dim)
"\nОдинаковых размеров не найдено"
)
((> (length eq_dim) 255)
"\nСлишком много групп одинаковых размеров"
)
(t
(mapcar
(function
(lambda (x)
(setq i (+ b i))
(mapcar
(function
(lambda (x)
(entmod (if (setq tmp (ASSOC 62 x))
(SUBST (cons 62 i) tmp x)
(append x (list (cons 62 i)))
)
)
)
)
x
)
)
)
eq_dim
)
(princ)
)
)
)Disney - класс!!!
От всего сердца спасибо!!!
Но только можно в коде поменять, чтобы изменялся цвет "текста" размерного стиля, а в программе изменяется цвет "общий". У меня размерные стили настроены - по слою и поэтому не вижу изменений
Вот код по моему меняет именно цвет текста, а не общий цвет:
(if aa4 (vl-cmdf "_.dimoverride" "dimclrt" aa4 "" aa3 ""))
:o
У меня размерные стили настроены - по слою и поэтому не вижу изменений
У меня, да и большинства нормальных людей тоже "по-слою", так что причина не в этом.
Вот вариант с заменой цвета только текста, если работать не будет выложи файл
(defun c:equal_dim_vla (/ all_dim car_meas tmp eq_dim i b)
(vl-load-com)
(setq all_dim
(mapcar 'vlax-ename->vla-Object
(vl-remove-if
'listp
(mapcar 'cadr
(ssnamex (ssget "_X" '((0 . "DIMENSION"))))
)
)
)
)
(while (car all_dim)
(setq car_meas (Vla-get-Measurement (car all_dim))
tmp (list
(vl-remove-if-not
(function (lambda (a)
(equal (Vla-get-Measurement a) car_meas 1e-12)
)
)
all_dim
)
)
eq_dim (cons (car tmp) eq_dim)
all_dim (vl-remove-if
(function
(lambda (a)
(equal (Vla-get-Measurement a) car_meas 1e-12)
)
)
all_dim
)
tmp nil
)
)
(setq eq_dim (vl-remove-if
(function (lambda (x) (= (length x) 1)))
eq_dim
)
i 0
b (cond
((>= 6 (length eq_dim))
1
)
((>= 12 (length eq_dim))
20
)
((>= 24 (length eq_dim))
10
)
(t 1)
)
)
(cond
((not eq_dim)
"Одинаковых размеров не найдено"
)
((> (length eq_dim) 255)
"Групп одинаковых размеров слишком много"
)
(t
(mapcar
(function
(lambda (x)
(setq i (+ b i))
(mapcar
(function
(lambda (x)
(vla-put-TextColor
x
i
)
)
)
x
)
)
)
eq_dim
)
(princ)
)
)
)Disney:
А если цвет текста надо будет пометь не на красный. Где изменить? Как вообще цвета назначаются?
Спасибо за внимание и за помощь. Дай Бог тебе здоровья.
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → LISP → Поиск дублированных размеров
Форум работает на PunBB, при поддержке Informer Technologies, Inc
