Re: Как добавить вершину в полилинию нажатием одной кнопки?
Черт, опять форматирование слетело. В общем, там комментарии надо будет подправить
Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Как добавить вершину в полилинию нажатием одной кнопки? (Страница 2 из 4)
Форумы CADUser → Программирование → LISP → Как добавить вершину в полилинию нажатием одной кнопки?
Сообщения с 26 по 50 из 86
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Подожди-ка, что-то совсем у меня не работает последний вариант. После запроса
Укажите точку разрыва :
тыкай не тыкай, ничего не происходит и просто программа тихо кончается. Может, ты поторопился в чем-то? Тут у тебя столько коментариев, трудно разобраться. Старый вариант еще раз проверил, работает, черт возьми, натыкал вершин сколько угодно. Может, не надо торопиться?
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Понятно, один символ неправильно сделал, да за компанию еще раз проверил на правый клик - не работает, зараза. Или у меня мозги уже кипять (тоже вариант, между прочим). Чем выискивать, попробуй:
;|=============================================================================
* Функция разрыва полилинии и одновременной передвижки новой вершины.
* Полилиния не меняет следующих свойств: цвет, слой, тип.
* Ограничения:
* 1. Не производится отлов ошибок ввода (никто не запрещает работать с арками и
* окружностями)
* 2. Не производится отлов нажатия Esc - не выполняется восстановление
* системных переменных. Обработчик ошибок писать просто некогда.
* 3. Не производится проверка usc, в которой работает пользователь.
* 4. Неправильное указание точки (не принадлежащей объекту) может свалить
* функцию в ноль.
* 5. Не отслеживается "заморозка" слоя.
* 6. Не отслеживается вариант, когда указывается пересечение двух объектов -
* в таком случае работа непредсказуема.
* Функция тестировалась на ADT 2005, usc = world.
*
* Функцию желательно сохранить в файл kpblc-stretch-pline.lsp. Файл должен
* быть сохранен в путях поддержки AutoCAD.
* Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
=============================================================================|;
(defun kpblc-stretch-pline (/ break_point _osmode_ selset_oper break_ent break_ent_type)
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline (ent-pline ent-type break-point)
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes" "")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch" "_C" break-point break-point "" break-point pause)
) ;_ end of defun
;; Конец определения локальных функций
(vl-load-com)
(if (not *kpblc-activedoc*)
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of if
(vla-endundomark *kpblc-activedoc*)
(vla-startundomark *kpblc-activedoc*)
(setq _osmode_ (getvar "osmode")
) ;_ end of setq
(setvar "osmode" 512)
(setq break_point (getpoint "\nУкажите точку разрыва : ")
selset_oper (ssget break_point)
) ;_ end of setq
;; Теперь проверка на вшивость - в смысле, на правильность выбора
;; Вынесено специально в отдельный setq, а также введена дополнительная
;; локальная переменная определения типа разрываемого объекта
(setq break_ent (ssname selset_oper 0)
break_ent_type (cdr (assoc 0 (entget break_ent)))
) ;_ end of setq
(cond
((= break_ent_type "LWPOLYLINE")
(progn
(_kpblc-break-pline break_ent nil break_point)
) ;_ end of progn
)
((= break_ent_type "LINE")
(_kpblc-break-pline break_ent t break_point)
)
(t (alert "Добавить вершину к выбранному примитиву невозможно!"))
) ;_ end of cond
(setvar "osmode" _osmode_)
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_ end of defun
(defun c:pline-str ()
(kpblc-stretch-pline)
) ;_ end of defun
;;; Конец файла kpblc-stretch-pline.lsp- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Обработка правого клика не производится. Поведение фактически такое же, как и раньше - добавлена обработка отрезков (и отказ от обработки других) только и обрамлено для _undo.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Так, теперь работает. Отрезок без сообщения превратился в полилинию. Дуговой сегмент делится на 2 дуговых сегмента. Может, вот этот запрос:
Укажите точку разрыва :
заменить на:
Укажите точку разрыва и положение новой вершины:
а то надо догадываться, что вершину можно таскать, хотя это и так видно. Если сгладить полилинию, то она не отрабатывается и выдается предусмотренное сообщение.
Нажатие правой кнопки портит, конечно, картину, но поскольку предложения нажать правую кнопку мыши не поступает в командной строке, то можно надеяться, что ее и не будут нажимать. Самое печальное пока - это то, что при нажатии левой кнопки мыши для указания места разрыва в пустом месте программа вылетает аварийно. Это мелочь, вроде бы, зачем указывать точку разрыва в пустоте, но, думаю, ты таких вещей не любишь.
В целом мне нравится, я беру ее в свой арсенал, спасибо, ну а как уж ты решишь дальше поступить с этой программой - тебе виднее.
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Да тут я еще одного товарища подключил, он вроде как обещал просмотреть.
Сглаженная полилиния на самом деле по (entget(car(entsel))) выдает нечто типа
((-1 . <Entity name: 7ec071a0>) (0 . "POLYLINE") (330 . <Entity name: 7ef5ad18>) (5 . "AC") (100 . "AcDbEntity") (67 . 0) (410 . "Model") <...>
- т.е. это не стандартная полилиния.
Но, поскольку она поддерживается командой _pedit, подключаем и ее (поскольку 3dpolyline не обрабатывается нормально, то ее не включаем):
;|=============================================================================
* Функция разрыва полилинии и одновременной передвижки новой вершины.
* Полилиния не меняет следующих свойств: цвет, слой, тип.
* Ограничения:
* 1. Не производится отлов ошибок ввода (никто не запрещает работать с арками и
* окружностями)
* 2. Не производится отлов нажатия Esc - не выполняется восстановление
* системных переменных. Обработчик ошибок писать просто некогда.
* 3. Не производится проверка usc, в которой работает пользователь.
* 4. Неправильное указание точки (не принадлежащей объекту) может свалить
* функцию в ноль.
* 5. Не отслеживается "заморозка" слоя.
* 6. Не отслеживается вариант, когда указывается пересечение двух объектов -
* в таком случае работа непредсказуема.
* Функция тестировалась на ADT 2005, usc = world.
*
* Функцию желательно сохранить в файл kpblc-stretch-pline.lsp. Файл должен
* быть сохранен в путях поддержки AutoCAD.
* Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
=============================================================================|;
(defun kpblc-stretch-pline (/ break_point _osmode_ selset_oper break_ent break_ent_type)
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline (ent-pline ent-type break-point)
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes" "")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch" "_C" break-point break-point "" break-point pause)
) ;_ end of defun
;; Конец определения локальных функций
(vl-load-com)
(if (not *kpblc-activedoc*)
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of if
(vla-endundomark *kpblc-activedoc*)
(vla-startundomark *kpblc-activedoc*)
(setq _osmode_ (getvar "osmode")
) ;_ end of setq
(setvar "osmode" 512)
;; Обработка пустого выбора
(while (not (setq break_point (getpoint "\nУкажите точку разрыва : ")
selset_oper (ssget break_point)
) ;_ end of setq
) ;_ end of not
) ;_ end of while
;; Теперь проверка на вшивость - в смысле, на правильность выбора
;; Вынесено специально в отдельный setq, а также введена дополнительная
;; локальная переменная определения типа разрываемого объекта
(setq break_ent (ssname selset_oper 0)
break_ent_type (cdr (assoc 0 (entget break_ent)))
) ;_ end of setq
(cond
((or (= break_ent_type "LWPOLYLINE") (= break_ent_type "POLYLINE"))
(progn
(_kpblc-break-pline break_ent nil break_point)
) ;_ end of progn
)
((= break_ent_type "LINE")
(_kpblc-break-pline break_ent t break_point)
)
(t (alert "Добавить вершину к выбранному примитиву невозможно!"))
) ;_ end of cond
(setvar "osmode" _osmode_)
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_ end of defun
(defun c:pline-str ()
(kpblc-stretch-pline)
) ;_ end of defun
;;; Конец файла kpblc-stretch-pline.lspБудут баги - прошу сообщить, будет дорабатывать ;)
- APavl
- Восстановленный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Еще можно найти в ToolPac 9.0 , там это есть . Как ,впрочем, и много чего другого
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Поступило предложение: вместо
(command "_.stretch" "_C" break-point break-point "" break-point pause)
поставить
(command "_.stretch" "_C" break-point break-point "" break-point (getpoint "Укажите конечную точку : "))
В таком случае нормально обрабатывается вариант нажатия на правую кнопку мыши, но не рисуются "резиновые" отрезки от вершин полилинии. Полный код приводить уже не буду
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Автор предложения: dvim.
> APavl
За toolpac платить надо однако, да и изучать его по полной программе, на что иногда нет ни времени, ни сил.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Предлагаю, в свою очередь вместо
(command "_.stretch" "_C" break-point break-point "" break-point pause)
поставить
(command "_.stretch" "_C" break-point break-point "" break-point (getpoint break_point "Укажите новую точку : "))
Новую, потому что команда "_stretch" скрыта от пользователя.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Pancake, посмотрел на последнюю строку - прямо бред какой-то - сплошные break_point.
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Так, dvim обнаружил еще одну ошибку в последнем коде: кусок
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline (ent-pline ent-type break-point)
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes" "")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch" "_C" break-point break-point "" break-point pause)
) ;_ end of defun
;; Конец определения локальных функцийзаменить на
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline (ent-pline ent-type break-point)
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch" "_C" break-point break-point "" break-point pause)
) ;_ end of defun
;; Конец определения локальных функцийЛюбопытно, хоть кто-нибудь потом разберется, что и как здесь навалено? :lol:
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Вот и на окончательный вариант я созрел сделать:
;|=============================================================================
* Функция разрыва полилинии и одновременной передвижки новой вершины.
* Соавторы и главные тестеры:
* Владимир Громов
* dvim
* Идея написания: Azor (https://www.caduser.ru/forum/topic20243.html)
* Полилиния не меняет следующих свойств: цвет, слой, тип.
* Ограничения:
* 1. Не производится отлов ошибок ввода (никто не запрещает работать с арками и
* окружностями)
* 2. Не производится отлов нажатия Esc - не выполняется восстановление
* системных переменных. Обработчик ошибок писать просто некогда.
* 3. Не производится проверка usc, в которой работает пользователь.
* 4. Неправильное указание точки (не принадлежащей объекту) может свалить
* функцию в ноль.
* 5. Не отслеживается "заморозка" слоя.
* 6. Не отслеживается вариант, когда указывается пересечение двух объектов -
* в таком случае работа непредсказуема.
* Функция тестировалась на ADT 2005, usc = world.
*
* Функцию желательно сохранить в файл kpblc-stretch-pline.lsp. Файл должен
* быть сохранен в путях поддержки AutoCAD.
* Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
=============================================================================|;
(defun kpblc-stretch-pline (/ break_point _osmode_ selset_oper break_ent break_ent_type)
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline (ent-pline ent-type break-point)
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch" "_C" break-point break-point "" break-point (getpoint break_point "Укажите новую точку : "))
) ;_ end of defun
;; Конец определения локальных функций
(vl-load-com)
(if (not *kpblc-activedoc*)
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of if
(vla-endundomark *kpblc-activedoc*)
(vla-startundomark *kpblc-activedoc*)
(setq _osmode_ (getvar "osmode")
) ;_ end of setq
(setvar "osmode" 512)
;; Обработка пустого выбора
(while (not (setq break_point (getpoint "\nУкажите точку разрыва : ")
selset_oper (ssget break_point)
) ;_ end of setq
) ;_ end of not
) ;_ end of while
;; Теперь проверка на вшивость - в смысле, на правильность выбора
;; Вынесено специально в отдельный setq, а также введена дополнительная
;; локальная переменная определения типа разрываемого объекта
(setq break_ent (ssname selset_oper 0)
break_ent_type (cdr (assoc 0 (entget break_ent)))
) ;_ end of setq
(cond
((or (= break_ent_type "LWPOLYLINE") (= break_ent_type "POLYLINE"))
(progn
(_kpblc-break-pline break_ent nil break_point)
) ;_ end of progn
)
((= break_ent_type "LINE")
(_kpblc-break-pline break_ent t break_point)
)
(t (alert "Добавить вершину к выбранному примитиву невозможно!"))
) ;_ end of cond
(setvar "osmode" _osmode_)
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_ end of defun
(defun c:pline-str ()
(kpblc-stretch-pline)
) ;_ end of defun
;;; Конец файла kpblc-stretch-pline.lspRe: Как добавить вершину в полилинию нажатием одной кнопки?
> Azor
Предлагаю из своего архива. Делал для выполнения полилинией рисунков (не чертежей).
;inspl.lsp == insert_polyline == вставка полилинии
; Запуск из командной строки: INSPL.
; Для рисования сегментов используется команда PLINE. Для удаления - команда
; BREAK. Для присоединения - команда PEDIT_join.
; На приглашение <First... > следует указать на исходной полилинии первую
; точку разрыва. На приглашения <Next point: > следует указывать точки
; вставляемого участка полилинии. Для окончания ввода - нажать ENTER или
; правую кнопку мыши. Последняя из введенных точек привязывается к
; ближайшей точке и является второй точкой разрыва для команды BREAK и
; точкой соединения для команды PEDIT_join. Пока привязка последней точки не
; осуществилась, или осуществилась но не к первоначально указанной полилинии,
; то будет предложен по приглашению <Not_second_break_point...> повторный ввод
; точки и выполнена привязка к ближайшей точке, пока привязка не осуществится
; или, пока не будет выбрано <Ignore>. Если выбрано игнорирование, т.е.
; подтверждено, что последняя точка правильная, то второй точкой разрыва
; становится ближайший к последней из введенных точек конец полилинии.
; Другими словами: если последняя точка указана не на полилинии, то
; удаляется один из концов полилинии. Тот, к которому ближе точка.
; Если на приглашение <First... > будет указана одна из двух крайних точек,
; то команда BREAK выполняться не будет, а введенный участок полилинии будет
; присоединен к первоначально указанной полилинии.
; Опция <F> по действию аналогична такой же опции в команде BREAK. Если при
; работе с опцией <F> точки разрыва указывать не на первоначально выбранном
; объекте, то результат может оказаться не таким, как ожидался.
;Help:
(defun hlpinspl () (textpage) (foreach nam '(
"15 июня 1998 - 17 мая 1999 / Киев / ttt"
""
"Команда предназначена для присоединения к полилинии новых сегментов"
"взамен удаляемых."
""
"ПРИГЛАШЕНИЯ И СООБЩЕНИЯ:"
"<First_break_point or F/Help:> - укажи точку на полилинии или введи <f>,<h>."
" <Press ENTER: > - нажми <ENTER> для выхода из окна помощи."
" <Try again...> - объект не выбран, повтори ввод."
" <Next_point: > - укажи точку или для окончания нажми <ENTER>."
" <Bad osnap. Next_point/<Ignore>: > - невозможно привязать точку к"
" полилинии. Укажи точку на полилинии или нажми <ENTER>."
""
"Дополнительную информацию см. в начале файла inspl.lsp"
) (princ (strcat "\n" nam))))
(defun insper (s)
(if (/= s "Function cancelled") (princ (strcat "\nError: " s)) )
(setvar "cmdecho" ocmd) (setvar "blipmode" oblp) (setvar "osmode" oosm)
(setvar "plinetype" oplt) (setq *error* olderr) (princ)
)
;выбор п-линии ;для C:...
(defun pick_6 ( / flgz6);т.указания ptx, msg_p6 и sel_pl - glob. для C:...
(setq flgz6 t)
(while flgz6
(initget "Help F")
(setq msg_p6 (entsel "\nOsnap_nea. First_break_point or F/Help: "))
(cond
((= msg_p6 "Help") (hlpinspl) (getstring "\nPress ENTER: "));---синт.
((= (type msg_p6) 'LIST)
(setq name_sel (cdr (assoc 0 (entget (setq sel_pl (car msg_p6)))))
);для C:...
(if (or (= "POLYLINE" name_sel) (= "LWPOLYLINE" name_sel))
(if (setq ptx (osnap (cadr msg_p6) "_nea"));---почему точка указания
(setq flgz6 nil);для прерывания цикла while ;лежит не на оси?
(princ "\nBad point.");---синт.
)
)
)
((= msg_p6 nil) (princ "\nTry again..."));---синт.
((= msg_p6 "F")
(setq msg_p6 (entsel))
(setq name_sel (cdr (assoc 0 (entget (setq sel_pl (car msg_p6)))))
);для C:...
(if (or (= "POLYLINE" name_sel) (= "LWPOLYLINE" name_sel))
(if (setq ptx (osnap (getpoint "\nOsnap_nea. First_break_point: ") "_nea"))
(setq flgz6 nil);для прерывания цикла while
(princ "\nBad point.");---синт.
)
)
)
);cond
(if name_sel (princ (strcat "\nObject: " name_sel ".")));---синт.
);while
);defun
;Функция раборает с LWPOLYLINE. Для C:...
;Запись в pt_end последней вершины полилинии lwpll, а в pt_beg первой:
(defun lastptlwp (lwpll / ent_lst element1 flg)
(setq ent_lst (entget lwpll))
(setq flg t)
(while flg
(setq element1 (car ent_lst))
(setq ent_lst (cdr ent_lst))
(if (= (car element1) 10)
(setq pt_beg (cdr element1) flg nil)
)
)
(while (setq element1 (car ent_lst))
(setq ent_lst (cdr ent_lst))
(if (= (car element1) 10)
(setq pt_end (cdr element1))
)
)
);---сократить setq, анн. flg
(defun C:INSPL ( / olderr oosm ocmd oblp
ptx sel_pl ins_pl prprpt nxtpt msg_p6 br_pla prpt
ver_pl pt_beg pt_end ffllgg ttmmpp pt_nea
name_sel oplt)
(setq olderr *error* *error* insper)
(setq ocmd (getvar "cmdecho") oosm (getvar "osmode") oblp (getvar "blipmode")
oplt (getvar "plinetype")
)
(setvar "blipmode" 0) (setvar "cmdecho" 0)
(pick_6)
(setvar "osmode" 0)
(if (= "LWPOLYLINE" name_sel) (setvar "plinetype" 2) (setvar "plinetype" 0))
(command "_PLINE" ptx);1 точка
(setq nxtpt (getpoint ptx "\nOsnap_nea. Next_point: "));2 точка
(command nxtpt)
(setq prprpt ptx);сохраняется 1 точка
(setq prpt nxtpt);сохраняется 2 точка
(setq nxtpt (getpoint prpt "\nOsnap_nea. Next_point: "));3 точка
(while nxtpt
(command nxtpt);3 и последующие точки
(setq prprpt prpt);предпредыдущая точка
(setq prpt nxtpt) ;предыдущая точка
(setq nxtpt (getpoint prpt "\nOsnap_nea. Next_point: "));4 и последующие точки
)
(command "_u");аннулируется сегмент т.к. последняя точка м.б. не на п-линии
(setq nxtpt (osnap prpt "_nea"));привязка последней точки
(if (and nxtpt (not (ssmemb sel_pl (ssget "_C" nxtpt nxtpt))))
(setq nxtpt nil)
);если есть привязка, но не к нашей п-линии, то потребуется подтверждение
;последней точки или ввод новой.
(while (not nxtpt)
(initget "Ignore");указать точку заново или подтверждение последней точки:
(setq nxtpt (getpoint prprpt
"\nNot_second_break_point. Osnap_nea. Next_point/<Ignore>: "))
(if (= nxtpt "Ignore") (setq nxtpt nil))
(if nxtpt
(progn ;выбрано Next_point.
(setq nxtpt (osnap nxtpt "_nea"));Если нет привязки, то повторить цикл
(if (and nxtpt (not (ssmemb sel_pl (ssget "_C" nxtpt nxtpt))))
(setq nxtpt nil)
);если есть привязка, но не к нашей п-линии, то потреб. подтверждение
)
(progn ;выбрано Ignore
(if (= "LWPOLYLINE" name_sel)
(lastptlwp sel_pl);Запись в pt_end последней точки, в pt_beg первой
(progn
(setq ver_pl (entnext sel_pl))
(setq pt_beg (cdr (assoc 10 (entget ver_pl))) )
(setq ver_pl (entnext ver_pl));---
(setq ffllgg t)
(while ffllgg ;вычисление конечной точки ;---можно проще?
(setq pt_end (cdr (assoc 10 (entget ver_pl))) )
(setq ver_pl (entnext ver_pl))
(if (= (cdr (assoc 0 (entget ver_pl))) "SEQEND")
(setq ffllgg nil)
)
)
)
)
(if (> (distance pt_beg prpt) (distance pt_end prpt))
(setq pt_nea pt_end)
(setq pt_nea pt_beg)
)
(setq nxtpt prpt)
)
)
);ввод точки пока не осуществится привязка или пока не выбрано Ignore
(setvar "osmode" 0)
(command nxtpt ""); последняя точка
(setq ins_pl (entlast))
(if (or (and (= (car ptx) (car pt_beg)) (= (cadr ptx) (cadr pt_beg)))
(and (= (car ptx) (car pt_end)) (= (cadr ptx) (cadr pt_end)))
)
(command "_PEDIT" sel_pl "_j" ins_pl "" "")
(progn
(command "_BREAK" msg_p6 "_f" ptx (if pt_beg pt_nea nxtpt))
(setq br_pl (entlast));1-й отрезок разорванной п-линии
(entdel br_pl);временное удаление
(setq br_pla (entlast));2-й отрезок разорванной п-линии
;---а если отрезок один?
(entdel br_pl);восстановление
(command "_PEDIT" br_pl "_J" br_pla ins_pl sel_pl "" "")
)
)
(setvar "osmode" oosm) (setvar "cmdecho" ocmd) (setvar "blipmode" oblp)
(setvar "plinetype" oplt)
(setq *error* olderr)
(princ)
)
;Для модернизации: сделать доступными все опции PLINE.>All
Критика и улучшения - приветствуются.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> ttt
Должен сказать, что сообщения в командной строке сбивают с толку. Вроде надо бы указать точку на полилинии, а курсор имеет вид прицела выбора объектов. Прочитал я коментарии, но как-то не отложилось в голове, можно сказать - "интуитивно-непонятный интерфейс", прошу прощения. С полилинией состоящей из дуговых сегментов происходит что-то непонятное - они просто исчезают. Вообще сложновата программа для изначально поставленной здесь задачи, IMHO.
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> {Владимир Громов}
В целом с оценкой согласен, тем более, что привязанность к нестандартным интерфейсам у меня с детства :)
Поскольку с программой приходится работать регулярно, то был бы рад, если бы удалось улучшить ее "малой кровью". Большими переделками заниматься пока не могу.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Еще замечания. Можно добавить вершину в отрезке, причем получается полилиния с 3 вершинами. Можно в качестве точки разрыва указать вершину полилинии (как пересечение) и, невзирая не сообщение "No valid objects selected.", вершина просто перемещается в другое место.
kpblc, отправишь ли ты эту программу в "Готовые программы" или нет?
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> Владимир Громов
Да я, если честно, уже и забыть успел об этой проге.
По замечаниям:
Можно добавить вершину в отрезке, причем получается полилиния с 3 вершинами.
Ну планировалось-то это дело под полилинии, так что... Хотя сделать анализ количества вершин полилинии можно, и, если вершин 3, выдать запрос на разбитие (может оказаться, что разбивать надо не всегда). ИМХО не надо - лишние телодвижения.
Можно в качестве точки разрыва указать вершину полилинии (как пересечение) и, невзирая не сообщение "No valid objects selected.", вершина просто перемещается в другое место.
Вот тут не понял. Вершины-то можно и просто так перетаскивать. Или разговор не про стандартный _.stretch?
И опять-таки - функция не завершена. Надо слишком много дополнять и переделывать, а у меня сейчас шансов практически ноль на это дело. Может, потом как-нить сделаю все вместе. Для затравки:
;;; Преобразование переданного примитива в список
;;; обрабатывает примитивы типа (entlast), vla-объекты и
;;; списки с группой -1. Для остальных возвращает nil
(defun lib:ent-to-ename (ent)
(cond
((= (type ent) 'ename) ent)
((= (type ent) 'vla-object) (vlax-vla-object->ename ent))
((= (type ent) 'list) (cdr (assoc -1 ent)))
(t nil)
) ;_ end of cond
) ;_ end of defun
;;; Возвращает имя объекта слоя типа <Entity name: 7efdac80>
;;; Параметры вызова:
;;; ent - имя примитива, для которого надо получить слой.
(defun lib:layer-by-object (ent / layer)
(setq ent (lib:ent-to-ename ent)
layer (tblobjname "layer" (cdr (assoc 8 ent)))
) ;_ end of setq
(lib:ent-to-ename layer)
) ;_ end of defun
;;; Определяет, изменяемый слой или нет
;;; Если слой незаблокирован и не заморожен, то t, иначе nil
;;; Параметры вызова:
;;; layer - имя слоя либо хендл типа <Entity name: 7efdac80>
(defun lib:layer-is-changed (layer)
(if (= (type layer) 'str)
(setq layer (tblobjname "layer" layer))
) ;_ end of if
(= (cdr (assoc 70 (entget layer))) 0)
) ;_ end of defun
;|=============================================================================
* Восстанавливаются системные переменные. Значения системных переменных
* должны храниться в глобальном списке *kpblc-sysvar-list*. Если списка нет
* (nil), происходит просто выход.
* Параметры вызова:
* Нет
* Примеры вызова:
(kpblc-error-restore-sysvar)
=============================================================================|;
(defun kpblc-error-restore-sysvar ()
(if *kpblc-sysvar-list*
(foreach item *kpblc-sysvar-list*
(setvar (car item) (cadr item))
) ;_ end of foreach
) ;_ end of if
(setq *kpblc-sysvar-list* nil)
(gc)
) ;_ end of defun
;|=======================================================================================
* Сохраняется текущее значение системных переменных. Список глобальный (*kpblc-sysvar-list*)
* При условии, что заданы значения, они устанавливаются.
* Поскольку список *kpblc-sysvar-list* не обнуляется, в нем хранится история изменения
* значений переменных.
* Параметры вызова:
* *kpblc-sysvar-list* список системных переменных, состояние которых надо сохранить.
* Список состоит из подсписков (Переменная Значение)
* В списке могут повторяться Переменные. В таком случае будет
* установлено последнее значение.
* Если в качестве второго параметра используется nil, то значение
* системной переменной просто сохраняется.
* Примеры вызова:
(kpblc-error-sysvar-list (list '("cmdecho" 0) '("blipmode") '("osmode" 503)))
(kpblc-error-sysvar-list (kpblc-get-all-sysvar-list))
=======================================================================================|;
(defun kpblc-error-save-sysvar (sysvar-list)
(foreach item sysvar-list
(setq *kpblc-sysvar-list*
(cons
(list (car item) (getvar (car item)))
*kpblc-sysvar-list*
) ;_ end of cons
) ;_ end of setq
(if (cadr item) ; передано устанавливаемое значение
(setvar (car item) (cadr item))
) ;_ end of if
) ;_ end of foreach
) ;_ end of defun
;|=============================================================================
* Стандартный обработчик ошибок AutoCAD
=============================================================================|;
(defun kpblc-error (message)
(if (member message
'("console break" "Function cancelled"
"Функция отменена" "quit / exit abort"
"выйти прервать"
) ;_list
) ;_member
(princ "\nКоманда прервана пользователем")
(princ
(strcat "\ERRNO # "
(itoa (getvar "ERRNO")) ;_itoa
": "
message
"\n"
) ;_strcat
) ;_princ
) ;_if
(kpblc-error-restore-sysvar)
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_defunВычисление *kpblc-activedoc* уже не даю - вроде как было.
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Инициализацию своего обработчика уж указывать не буду - работать тоже иногда надо, отвлекают от форума, сволочи :)
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Это у меня не критические замечания, а, скажем так, описание "недокументированных возможностей". Программа из
kpblc (2005-09-09 17:48:29)
хорошо работает, вылетов я не обнаружил.
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
А как она себя ведет на заблокированных слоях?
- SAVRD
- Восстановленный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Выложите пжлста окончательный вид!
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
> kpblc
Если полилиния находится на блокированном слое, то программа вылетает аварийно.
- kpblc
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Все, вроде как добил. Есть необрабатываемая ошибка указания пустой точки - функция вылетает. На это меня уже не хватат. Заблокированные слои временно разблокируются. Если в процессе обработки заблокированного слоя нажать Esc, то слой возвращается в начальный вариант. Надеюсь, форматирование не накроется. Если накроется (т.е. будут непонятные ошибки), пишите, положу на webfile.
;;; Преобразование переданного примитива в список
;;; обрабатывает примитивы типа (entlast), vla-объекты и
;;; списки с группой -1. Для остальных возвращает nil
(defun lib:ent-to-ename (ent)
(cond
((= (type ent) 'ename) ent)
((= (type ent) 'vla-object) (vlax-vla-object->ename ent))
((= (type ent) 'list) (cdr (assoc -1 ent)))
(t nil)
) ;_ end of cond
) ;_ end of defun
;;; Возвращает имя объекта слоя типа <Entity name: 7efdac80>
;;; Параметры вызова:
;;; ent - имя примитива, для которого надо получить слой.
(defun lib:layer-by-object (ent / layer)
(setq ent (lib:ent-to-ename ent)
layer (tblobjname "layer" (cdr (assoc 8 (entget ent))))
) ;_ end of setq
(lib:ent-to-ename layer)
) ;_ end of defun
;;; Определяет, изменяемый слой или нет
;;; Если слой незаблокирован и не заморожен, то t, иначе nil
;;; Параметры вызова:
;;; layer - имя слоя либо хендл типа <Entity name: 7efdac80>
(defun lib:layer-is-changeable (layer)
(if (= (type layer) 'str)
(setq layer (tblobjname "layer" layer))
) ;_ end of if
(= (cdr (assoc 70 (entget layer))) 0)
) ;_ end of defun
;|==============================================================
* Восстанавливаются системные переменные. Значения системных
переменных
* должны храниться в глобальном списке *kpblc-sysvar-list*. Если
списка нет
* (nil), происходит просто выход.
* Параметры вызова:
* Нет
* Примеры вызова:
(kpblc-error-restore-sysvar)
==============================================================|;
(defun kpblc-error-restore-sysvar ()
(if *kpblc-sysvar-list*
(foreach item *kpblc-sysvar-list*
(setvar (car item) (cadr item))
) ;_ end of foreach
) ;_ end of if
(setq *kpblc-sysvar-list* nil)
(gc)
) ;_ end of defun
;|=======================================================================================
* Функция модификации указанного бита примитива
* Параметры вызова:
* entity - примитив, полученный через (entsel), (entlast) etc
* bit - dxf-код, значение которого надо установить
* value - новое значение
* regen - выполнять или нет регенерацию примитива сразу. t/ nil
* Примеры вызова:
(_kpblc-ent-modify (entlast) 8 "0" t) ; перенести последний примитив на слой 0
(_kpblc-ent-modify (entsel) 62 10 nil) ; установить выбранному примитиву цвет 10
* Возвращаемое значение:
* примитив с модифицированным dxf-списком. Примитив автоматически перерисовывается.
=======================================================================================|;
(defun _kpblc-ent-modify-autoregen (ent bit value
ext_regen / ent_list
old_dxf new_dxf layer_dxf70
)
(if (not
(and
(or
(= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
(= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
(= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
) ;_ end of or
(= bit 100)
) ;_ end of and
) ;_ end of not
(progn
(setq ent_list (entget ent)
new_dxf (cons bit
(if (and (= bit 62) (= (type value) 'str))
(if (= (strcase value) "BYLAYER")
256
0
) ;_ end of if
value
) ;_ end of if
) ;_ end of cons
) ;_ end of setq
(if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
(progn
(entmod (if old_dxf
(subst new_dxf old_dxf ent_list)
(append ent_list (list new_dxf))
) ;_ end of if
) ;_ end of entmod
(if ent_regen
(entupd ent)
(redraw ent)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
ent
) ;_ end of defun
;|================================================================
* Сохраняется текущее значение системных переменных. Список
глобальный (*kpblc-sysvar-list*)
* При условии, что заданы значения, они устанавливаются.
* Поскольку список *kpblc-sysvar-list* не обнуляется, в нем
хранится история изменения
* значений переменных.
* Параметры вызова:
* *kpblc-sysvar-list* список системных переменных, состояние
которых надо сохранить.
* Список состоит из подсписков (Переменная Значение)
* В списке могут повторяться Переменные. В таком случае будет
* установлено последнее значение.
* Если в качестве второго параметра используется nil, то
значение
* системной переменной просто сохраняется.
* Примеры вызова:
(kpblc-error-sysvar-list (list '("cmdecho" 0) '("blipmode")
'("osmode" 503)))
(kpblc-error-sysvar-list (kpblc-get-all-sysvar-list))
==============================================================|;
(defun kpblc-error-save-sysvar (sysvar-list)
(foreach item sysvar-list
(setq *kpblc-sysvar-list*
(cons
(list (car item) (getvar (car item)))
*kpblc-sysvar-list*
) ;_ end of cons
) ;_ end of setq
(if (cadr item) ; передано устанавливаемое значение
(setvar (car item) (cadr item))
) ;_ end of if
) ;_ end of foreach
) ;_ end of defun
;|==============================================================
* Стандартный обработчик ошибок AutoCAD
==============================================================|;
(defun kpblc-error (message)
(if (member message
'("console break" "Function cancelled"
"Функция отменена" "quit / exit abort"
"выйти прервать"
) ;_list
) ;_member
(princ "\nКоманда прервана пользователем")
(princ
(strcat "\ERRNO # "
(itoa (getvar "ERRNO")) ;_itoa
": "
message
"\n"
) ;_strcat
) ;_princ
) ;_if
(kpblc-error-restore-sysvar)
(if layer_status
(_kpblc-ent-modify-autoregen
(lib:layer-by-object (entlast))
70
layer_status
t
) ;_ end of _kpblc-ent-modify-autoregen
) ;_ end of if
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_ end of defun
;|==============================================================
* Функция разрыва полилинии и одновременной передвижки новой
вершины.
* Соавторы и главные тестеры:
* Владимир Громов
* dvim
* Идея написания:
* Azor (https://www.caduser.ru/forum/topic20243.html)
* Полилиния не меняет следующих свойств: цвет, слой, тип.
* Ограничения:
* 1. Не производится отлов ошибок ввода (никто не запрещает
* работать с арками и окружностями)
* 2. Не производится отлов нажатия Esc - не выполняется
* восстановление системных переменных. Обработчик ошибок писать
* просто некогда.
* 3. Не производится проверка usc, в которой работает
* пользователь.
* 4. Неправильное указание точки (не принадлежащей объекту)
* может свалить функцию в ноль.
* 5. Не отслеживается "заморозка" слоя.
* 6. Не отслеживается вариант, когда указывается пересечение
* двух объектов - в таком случае работа непредсказуема.
* Функция тестировалась на ADT 2005, usc = world.
*
* Функцию желательно сохранить в файл kpblc-stretch-pline.lsp.
* Файл должен быть сохранен в путях поддержки AutoCAD.
* Возможный макрос для вызова:
^C^C(if (not "c:pline-str") (load "kpblc-stretch-pline.lsp"));c:pline-str;
==============================================================|;
(defun kpblc-stretch-pline (/ break_point
_osmode_ selset_oper
break_ent break_ent_type
*error*
)
;; Определения локальных функций
;; Собственно разрыв и дополнительный одновременный _.stretch.
;; Параметры:
;; ent_pline - ссылка на разрываемый объект, аналог (entsel)
;; ent_type - тип объекта: nil -> lwpolyline; t -> line
;; объект обратно в LINE не разбивается
(defun _kpblc-break-pline
(ent-pline ent-type break-point /)
(if (not
(lib:layer-is-changeable (lib:layer-by-object ent-pline))
) ;_ end of not
(progn
(setq layer_status
(cdr
(assoc 70
(entget (lib:layer-by-object ent-pline))
) ;_ end of assoc
) ;_ end of cdr
) ;_ end of setq
(_kpblc-ent-modify-autoregen
(lib:layer-by-object ent-pline)
70
0
t
) ;_ end of _kpblc-ent-modify-autoregen
) ;_ end of progn
) ;_ end of if
(command "_.break" ent-pline break-point break-point)
(command "_.pedit" "_M" "_C" break-point break-point "")
;; Здесь определяем по ent_type - чего делать дальше
(if ent-type
(command "_yes")
) ;_ end of if
(command "_join" 0 "")
(command "_.stretch"
"_C"
break-point
break-point
""
break-point
(getpoint break_point "Укажите новую точку : ")
) ;_ end of command
(if layer_status
(progn
(_kpblc-ent-modify-autoregen
(lib:layer-by-object (entlast))
70
layer_status
t
) ;_ end of _kpblc-ent-modify-autoregen
(setq layer_status nil)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
;; Конец определения локальных функций
(vl-load-com)
(setq *error* kpblc-error)
(if (not *kpblc-activedoc*)
(setq *kpblc-activedoc*
(vla-get-activedocument
(vlax-get-acad-object)
) ;_ end of vla-get-activedocument
) ;_ end of setq
) ;_ end of if
(vla-endundomark *kpblc-activedoc*)
(vla-startundomark *kpblc-activedoc*)
(kpblc-error-save-sysvar '(("osmode" 512)))
;; Обработка пустого выбора
(while (setq break_point
(getpoint "\nУкажите точку разрыва : ")
;;selset_oper (ssget break_point)
) ;_ end of setq
;; Теперь проверка на вшивость - в смысле, на правильность выбора
;; Вынесено специально в отдельный setq, а также введена дополнительная
;; локальная переменная определения типа разрываемого объекта
(setq selset_oper (ssget break_point)
break_ent (ssname selset_oper 0)
break_ent_type (cdr (assoc 0 (entget break_ent)))
) ;_ end of setq
(cond
((or (= break_ent_type "LWPOLYLINE")
(= break_ent_type
"POLYLINE"
) ;_ end of =
) ;_ end of or
(progn
(_kpblc-break-pline break_ent nil break_point)
) ;_ end of progn
)
((= break_ent_type "LINE")
(_kpblc-break-pline break_ent t break_point)
)
(t
(alert
"Добавить вершину к выбранному примитиву невозможно!"
) ;_ end of alert
) ;_ end of cond
) ;_ end of while
) ;_ end of while
(kpblc-error-restore-sysvar)
(vla-endundomark *kpblc-activedoc*)
(princ)
) ;_ end of defun
(defun c:pline-str ()
(kpblc-stretch-pline)
) ;_ end of defun
;;; Конец файла kpblc-stretch-pline.lspВызов: pline-str.
В процессе обработки исправил несколько критичных ошибок.
- Владимир Громов
- Активный участник
Re: Как добавить вершину в полилинию нажатием одной кнопки?
Эк, как ее раздуло, эту программу.:)
Сообщения с 26 по 50 из 86
Тему читают: 1 гость
Форумы CADUser → Программирование → LISP → Как добавить вершину в полилинию нажатием одной кнопки?
Форум работает на PunBB, при поддержке Informer Technologies, Inc
