Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Программирование → LISP → Подобие участка полилинии
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Здравствуйте!
Вот вторая идея. (Первая пост #35)
Задача в том, чтобы выполнить подобие полилинии (отрезка, сплайна), но не целиком, а участка, заданного двумя точками. Точки же могут находится не на линии, а в стороне. При этом граицы подобия определяются перпендикулярами. :)
Здравствуйте!
Вот вторая идея. (Первая пост #35)
Задача в том, чтобы выполнить подобие полилинии (отрезка, сплайна), но не целиком, а участка, заданного двумя точками. Точки же могут находится не на линии, а в стороне. При этом граицы подобия определяются перпендикулярами.
Начни с этого примера:
;;------------------------------------ COPS.LSP ----------------------------------;;
;; fixo () 2012 * all rights released
;; created 3/10/12
(defun C:COPS(/ *error* acsp adoc curve en encopy end1 end2 lay locked osm p1 p1c p1e p2 p2c p2e sset x)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(cond ((or (not msg)
(member msg '("console break" "Function cancelled" "quit / exit abort"))
)
)
((princ (strcat "\nError: " msg)))
)
(setvar "cmdecho" 1)
(if osm
(setvar "osmode" osm)
)
(if locked
(foreach x locked (vla-put-lock x :vlax-true))
)
(princ)
)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object))
acsp (vla-get-block(vla-get-activelayout adoc)))
(vla-startundomark adoc )
(while (not sset)
(setq sset (ssget "_:S:E" '((0 . "*LINE")))
)
)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint"\nПервая точка: ") )
(setq p2 (getpoint p1 "\nВторая точка: ") )
(setq en (ssname sset 0))
(setq curve (vlax-ename->vla-object en))
(setq lay (vla-item (vla-get-layers adoc)(vla-get-layer curve)))
(if (eq :vlax-true (vla-get-lock lay))
(progn
(setq locked (cons lay locked))
(vla-put-lock x :vlax-true)))
(setq p1e (vlax-curve-getclosestpointto en p1))
(setq p2e (vlax-curve-getclosestpointto en p2))
(command "_copy" en "" "_none" p1e "_none" p1)
(setq encopy (entlast))
(setq p1c (vlax-curve-getclosestpointto encopy p1))
(setq p2c (vlax-curve-getclosestpointto encopy p2))
(if (< (vlax-curve-getparamatpoint encopy p1c)(vlax-curve-getparamatpoint encopy p2c))
(progn
(setq end1 (vlax-curve-getstartpoint encopy))
(setq end2 (vlax-curve-getendpoint encopy)))
(progn
(setq end2 (vlax-curve-getstartpoint encopy))
(setq end1 (vlax-curve-getendpoint encopy))))
(vl-cmdf "_break" encopy "" p1c end1)
(setq encopy (entlast))
(vl-cmdf "_break" encopy "" p2c end2)
(ssdel en sset)
(*error* nil)
(princ)
)
(princ "\n\t---\tСтарт команда: \"COPS\"\t---")
(princ)
(or (vl-load-com)
(princ))
;;------------------------------------ code end ----------------------------------;;[FONT=Arial]~'J'~[/FONT]
Начни с этого примера
Близко, не не совсем то.
Вот на эту тему набросок
Понял, переделаем
[FONT=Arial]~'J'~[/FONT]
Близко, не не совсем то.
Вот на эту тему набросок
Пробуй еще раз:
;;------------------------------------ COPS.LSP ----------------------------------;;
;; fixo () 2012 * all rights released
;; created 3/10/12
;; edited 3/11/12 10:48 AM
(defun C:COPS(/ *error* a acsp adoc ang b curve en encopy end1 end2 input lay locked mp offset
osm p1 p1c p1e p2 p2c p2e p3 par scrpoint snapt sset temp x)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(cond ((or (not msg)
(member msg '("console break" "Function cancelled" "quit / exit abort"))
)
)
((princ (strcat "\nError: " msg)))
)
(setvar "cmdecho" 1)
(if osm
(setvar "osmode" osm)
)
(if locked
(foreach x locked (vla-put-lock x :vlax-true))
)
(princ)
)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object))
acsp (vla-get-block(vla-get-activelayout adoc)))
(vla-startundomark adoc )
(while (not sset)
(setq sset (ssget "_:S:E" '((0 . "*LINE")))
)
)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint"\nПервая точка: ") )
(setq p2 (getpoint p1 "\nВторая точка: ") )
(setq mp (trans (mapcar '(lambda(a b)(/ ( + a b)))p1 p2) 1 0))
(setq en (ssname sset 0))
(setq curve (vlax-ename->vla-object en))
(setq p1e (vlax-curve-getclosestpointto en p1))
(setq p2e (vlax-curve-getclosestpointto en p2))
(setq par (/ (+ (vlax-curve-getparamatpoint curve p1e)(vlax-curve-getparamatpoint curve p2e)) 2)
mp (vlax-curve-getpointatparam curve par)
)
(initget 7)
(setq offset (getreal "\nРасстояние : "))
(princ "\nНаправление: ")
(setq scrpoint nil)
(setq input 5)
(while (not (equal input 3))
(setq temp (grread T 1 0))
(redraw)
(setq input (car temp))
(setq scrpoint (cadr temp))
(grdraw scrpoint (setq snapt(vlax-curve-getclosestpointto curve scrpoint)) 1 -1)
)
(setq ang (angle snapt scrpoint))
(setq lay (vla-item (vla-get-layers adoc)(vla-get-layer curve)))
(if (eq :vlax-true (vla-get-lock lay))
(progn
(setq locked (cons lay locked))
(vla-put-lock x :vlax-true)))
(command "_copy" en "" "_none" snapt "_none" (polar snapt ang offset))
(setq encopy (entlast))
(setq p1c (vlax-curve-getclosestpointto encopy p1))
(setq p2c (vlax-curve-getclosestpointto encopy p2))
(if (< (vlax-curve-getparamatpoint encopy p1c)(vlax-curve-getparamatpoint encopy p2c))
(progn
(setq end1 (vlax-curve-getstartpoint encopy))
(setq end2 (vlax-curve-getendpoint encopy)))
(progn
(setq end2 (vlax-curve-getstartpoint encopy))
(setq end1 (vlax-curve-getendpoint encopy))))
(vl-cmdf "_break" encopy "" p1c end1)
(setq encopy (entlast))
(vl-cmdf "_break" encopy "" p2c end2)
(ssdel en sset)
(redraw)
(*error* nil)
(princ)
)
(princ "\n\t---\tСтарт команда: \"COPS\"\t---")
(princ)
(or (vl-load-com)
(princ))
;;------------------------------------ code end ----------------------------------;;[FONT=Arial]~'J'~[/FONT]
Команда копирует. Желательно, чтобы она выполняла подобие.
Вот накидал.
Команда копирует. Желательно, чтобы она выполняла подобие.
Вот накидал.
Проверь на подобие, вроде оно
;;------------------------------------ COPS.LSP ----------------------------------;;
;; fixo () 2012 * all rights released
;; created 3/10/12
;; edited 3/11/12 10:48 AM
;; edited 3/11/12 10:07 PM
(defun C:COPS(/ *error* a acsp adoc ang b curve en encopy end1 end2 input lay locked mp offset
osm p1 p1c p1e p2 p2c p2e p3 par scrpoint snapt sset temp x)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(cond ((or (not msg)
(member msg '("console break" "Function cancelled" "quit / exit abort"))
)
)
((princ (strcat "\nError: " msg)))
)
(setvar "cmdecho" 1)
(if osm
(setvar "osmode" osm)
)
(if locked
(foreach x locked (vla-put-lock x :vlax-true))
)
(princ)
)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object))
acsp (vla-get-block(vla-get-activelayout adoc)))
(vla-startundomark adoc )
(while (not sset)
(setq sset (ssget "_:S:E" '((0 . "*LINE")))
)
)
(setq osm (getvar "osmode"))
(setvar "osmode" 0)
(setq p1 (getpoint"\nПервая точка: ") )
(setq p2 (getpoint p1 "\nВторая точка: ") )
(setq mp (trans (mapcar '(lambda(a b)(/ ( + a b)))p1 p2) 1 0))
(setq en (ssname sset 0))
(setq curve (vlax-ename->vla-object en))
(setq p1e (vlax-curve-getclosestpointto en p1))
(setq p2e (vlax-curve-getclosestpointto en p2))
(setq par (/ (+ (vlax-curve-getparamatpoint curve p1e)(vlax-curve-getparamatpoint curve p2e)) 2)
mp (vlax-curve-getpointatparam curve par)
)
(initget 7)
(setq offset (getreal "\nРасстояние : "))
(princ "\nНаправление: ")
(setq scrpoint nil)
(setq input 5)
(while (not (equal input 3))
(setq temp (grread T 1 0))
(redraw)
(setq input (car temp))
(setq scrpoint (cadr temp))
(grdraw scrpoint (setq snapt(vlax-curve-getclosestpointto curve scrpoint)) 1 -1)
)
(setq ang (angle snapt scrpoint))
(setq lay (vla-item (vla-get-layers adoc)(vla-get-layer curve)))
(if (eq :vlax-true (vla-get-lock lay))
(progn
(setq locked (cons lay locked))
(vla-put-lock x :vlax-true)))
;;;(command "_copy" en "" "_none" snapt "_none" (polar snapt ang offset))
(setvar "offsetdist" offset)
(setvar "cmdecho" 1)
(command "_.offset" "" en (polar snapt ang offset))
(if (not (eq en (entlast)))
(command ""))
(setvar "cmdecho" 0)
(setq encopy (entlast))
(setq p1c (vlax-curve-getclosestpointto encopy p1))
(setq p2c (vlax-curve-getclosestpointto encopy p2))
(if (< (vlax-curve-getparamatpoint encopy p1c)(vlax-curve-getparamatpoint encopy p2c))
(progn
(setq end1 (vlax-curve-getstartpoint encopy))
(setq end2 (vlax-curve-getendpoint encopy)))
(progn
(setq end2 (vlax-curve-getstartpoint encopy))
(setq end1 (vlax-curve-getendpoint encopy))))
(vl-cmdf "_break" encopy "" p1c end1)
(setq encopy (entlast))
(vl-cmdf "_break" encopy "" p2c end2)
(ssdel en sset)
(redraw)
(*error* nil)
(princ)
)
(princ "\n\t---\tСтарт команда: \"COPS\"\t---")
(princ)
(or (vl-load-com)
(princ))
;;------------------------------------ code end ----------------------------------;;[FONT=Arial]~'J'~[/FONT]
Аплодисменты, зал стоит! Ура! Спасибо! Все работает как надо! :)
С Вашего позволения в 45-ой строке на свой вкус включил все привязки, люблю когда все привязки работают
(setvar "osmode" 15359)
Еще раз спасибо!
Ну и ладненько, рад если все срослось :)
[FONT=Arial]~'J'~[/FONT]
Добрый день!! Замечательный lisp!! Но нельзя ли сделать так, чтобы подобие участка полилинии (отрезка, сплайна), заданного двумя точками было с нулевым шагом (чтобы этот участок оставался поверх существующей полилинии)?!..
Не совсем понятен ваш вопрос, лучше бы посмотреть
чертеж с пояснениями, напр. на сайт:
www.webfile.ru и ссылку на файл сюда
[FONT=Arial]~'J'~[/FONT]
Думаю, что идея будет понятной..
файл:My Webpage
Пробуй особо не тестировал:
;;------------------------------------ DEP.LSP ----------------------------------;;
;; fixo () 2012 * all rights released
;; created 5/17/12
(defun C:DEP(/ *error* acsp adoc dd elist ln nom osm p1 p2 pickpt1 pickpt2 pline sset)
(defun *error* (msg)
(vla-endundomark (vla-get-activedocument
(vlax-get-acad-object))
)
(cond ((or (not msg)
(member msg '("console break" "Function cancelled" "quit / exit abort"))
)
)
((princ (strcat "\nError: " msg)))
)
(setvar "cmdecho" 1)
(if osm
(setvar "osmode" osm)
)
(if nom
(setvar "nomutt" nom)
)
(princ)
)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object))
acsp (vla-get-block(vla-get-activelayout adoc)))
(vla-startundomark adoc )
(setvar "cmdecho" 0)
(setq nom (getvar "nomutt"))
(setq osm (getvar "osmode"))
(setvar "osmode" 512)
(setq dd (/ (getvar "dimtxt") 2))
(if (and
(setq p1 (getpoint "\nПервая точка: "))
(setq p2 (getpoint p1 "\nВторая точка: "))
)
(progn
(setq pickpt1 (mapcar '+ p1 (list dd dd 0.0)))
(setq pickpt2 (mapcar '+ p1 (list (- dd) (- dd) 0.0)))
(setq sset (ssget "F" (list pickpt2 pickpt1) '((0 . "*LINE"))))
(setq pline (ssname sset 0))
(vl-cmdf "_copy" pline "" '(0 0 0) '(0 0 0))
(setq pline (entlast))
(vl-cmdf "_line" "_non" p1 "_non" p2 "")
(setq ln (entlast))
(setvar "nomutt" 0)
(princ "\nВыбрать точку на удаляемой части полилинии: ")
(setvar "nomutt" 1)
(vl-cmdf "_trim" ln "" pause "")
(setvar "nomutt" 0)
(entdel ln)
(setq pline (entlast))
(setq elist (entget pline))
;; раскомментировать по надобности :
;|
(if (assoc 62 elist)
(entmod (subst (cons 62 2)(assoc 62 elist) elist))
(entmod (append elist (list (cons 62 2)))))|;
)
)
(*error* nil)
(princ)
)
(princ "\n\t---\tСтарт команда: \"DEP\"\t---")
(princ)
(or (vl-load-com)
(princ))
;;------------------------------------ code end ----------------------------------;;[FONT=Arial]~'J'~[/FONT]
спасибо..!! в понедельник опробую как только приду на работу..
при выборе второй точки выдает ошибку:
Error: неверная строка режима ssget
Добрый день! Давно сюда не заходил, года идут AutoCAD меняется, почему-то перестал работать этот код, срабатывает подобие всей линии, а не участка как работало раньше, есть возможность починить его под современный автокад?
Страницы 1
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Программирование → LISP → Подобие участка полилинии
Форум работает на PunBB, при поддержке Informer Technologies, Inc
