Внутренний радиус командой fillet

Внутренний радиус командой fillet · 26.10.2009, 19:18

Есть необходимость делать радиуса на оборот (не выпуклым, а сделать впуклым ...)
Как сей момент можно реализовать?
У меня есть идея, но хз наскока реальная, надо чоб кто глянул из спецов по программированию или кто шарит луче меня

В файле вопрос и попытка к решению, только хз как програмно оформить...
Возможно в макросе, или LISP...

Кулик Алексей aka kpblc · 26.10.2009, 21:27

http://dwg.ru/dnl/607

sbi · 26.10.2009, 21:39

Или вручную
Команда: _fillet
Текущие настройки: Режим = С ОБРЕЗКОЙ, Радиус сопряжения = 0.0000
Выберите первый объект или [оТменить/полИлиния/раДиус/Обрезка/Несколько]: д
Радиус сопряжения <0.0000>: 10
Команда: _explode
Выберите объекты: найдено: 1
Команда: _mirror
Выберите объекты: найдено: 1
Первая точка оси отражения: Вторая точка оси отражения:
Удалить исходные объекты? [Да/Нет] <Н>: д

Do$ · 26.10.2009, 23:13

Сперва _explode
Потом - вот этим:

Код:

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

(defun c:inside_fillet (/ ent1 ent2 arc stp ept)
  (vl-load-com)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
  (setq old_cmdecho (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (while (and
	   (/= ent1 "Cancel")
	   (not (vl-catch-all-error-p ent1))
	   (not (vl-catch-all-error-p ent2))
	   (not	(and
		  (listp ent1)
		  (listp ent2)
		  (= (type (car ent1)) 'ENAME)
		  (= (type (car ent2)) 'ENAME)
		) ;_ end of and
	   ) ;_ end of not
	 ) ;_ end of and
    (if	ent1
      (progn
	(cond
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Radius")
	   ) ;_ end of and
	   (initget (+ 4 128))
	   (if (setq
		 ent1 nil
		 rad
		      (getdist (strcat "\nРадиус внутреннего скругления:<"
				       (rtos (getvar 'FILLETRAD) 2 4)
				       ">"
			       ) ;_ end of strcat
		      ) ;_ end of getdist
	       ) ;_ end of setq
	     (setvar 'FILLETRAD rad)
	     (princ (rtos (getvar 'FILLETRAD) 2 4))
	   ) ;_ end of if
	  )
	  ((and (listp ent1) (= (type (car ent1)) 'ENAME))
	   (setq ent2
		  (vl-catch-all-apply
		    (function (lambda () (entsel "\nУкажите второй объект:")))
		  ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	  )
	) ;_ end of cond
      ) ;_ end of progn
      (progn
	(initget "Радиус Отмена _Radius Cancel")
	(if
	  (not
	    (setq
	      ent1
	       (vl-catch-all-apply
		 (function
		   (lambda ()
		     (entsel
		       "\nУкажите первый объект, или:<Отмена>[Радиус/ Отмена]"
		     ) ;_ end of entsel
		   ) ;_ end of lambda
		 ) ;_ end of function
	       ) ;_ end of vl-catch-all-apply
	    ) ;_ end of setq
	  ) ;_ end of not
	   (setq ent1 "Cancel")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while
  (if (and
	(listp ent1)
	(listp ent2)
	(= (type (car ent1)) 'ENAME)
	(= (type (car ent2)) 'ENAME)
      ) ;_ end of and
    (vl-catch-all-apply
      (function	(lambda	()
		  (vl-cmdf "_.fillet" (car ent1) (car ent2))
		  (setq	arc (vlax-ename->vla-object (entlast))
			stp (vlax-curve-getStartPoint arc)
			ept (vlax-curve-getEndPoint arc)
		  ) ;_ end of setq
		  (if (/= (getvar 'FILLETRAD) 0)
		    (vl-cmdf "_.mirror" (entlast) "" stp ept "_y")
		  ) ;_ end of if
		) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of if
  (setvar 'CMDECHO old_cmdecho)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

Positron · 27.10.2009, 11:41

Цитата:

Сообщение от Do$

Сперва _explode
Потом - вот этим:

Код:

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

(defun c:inside_fillet (/ ent1 ent2 arc stp ept)
  (vl-load-com)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
  (setq old_cmdecho (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (while (and
	   (/= ent1 "Cancel")
	   (not (vl-catch-all-error-p ent1))
	   (not (vl-catch-all-error-p ent2))
	   (not	(and
		  (listp ent1)
		  (listp ent2)
		  (= (type (car ent1)) 'ENAME)
		  (= (type (car ent2)) 'ENAME)
		) ;_ end of and
	   ) ;_ end of not
	 ) ;_ end of and
    (if	ent1
      (progn
	(cond
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Radius")
	   ) ;_ end of and
	   (initget (+ 4 128))
	   (if (setq
		 ent1 nil
		 rad
		      (getdist (strcat "\nРадиус внутреннего скругления:<"
				       (rtos (getvar 'FILLETRAD) 2 4)
				       ">"
			       ) ;_ end of strcat
		      ) ;_ end of getdist
	       ) ;_ end of setq
	     (setvar 'FILLETRAD rad)
	     (princ (rtos (getvar 'FILLETRAD) 2 4))
	   ) ;_ end of if
	  )
	  ((and (listp ent1) (= (type (car ent1)) 'ENAME))
	   (setq ent2
		  (vl-catch-all-apply
		    (function (lambda () (entsel "\nУкажите второй объект:")))
		  ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	  )
	) ;_ end of cond
      ) ;_ end of progn
      (progn
	(initget "Радиус Отмена _Radius Cancel")
	(if
	  (not
	    (setq
	      ent1
	       (vl-catch-all-apply
		 (function
		   (lambda ()
		     (entsel
		       "\nУкажите первый объект, или:<Отмена>[Радиус/ Отмена]"
		     ) ;_ end of entsel
		   ) ;_ end of lambda
		 ) ;_ end of function
	       ) ;_ end of vl-catch-all-apply
	    ) ;_ end of setq
	  ) ;_ end of not
	   (setq ent1 "Cancel")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while
  (if (and
	(listp ent1)
	(listp ent2)
	(= (type (car ent1)) 'ENAME)
	(= (type (car ent2)) 'ENAME)
      ) ;_ end of and
    (vl-catch-all-apply
      (function	(lambda	()
		  (vl-cmdf "_.fillet" (car ent1) (car ent2))
		  (setq	arc (vlax-ename->vla-object (entlast))
			stp (vlax-curve-getStartPoint arc)
			ept (vlax-curve-getEndPoint arc)
		  ) ;_ end of setq
		  (if (/= (getvar 'FILLETRAD) 0)
		    (vl-cmdf "_.mirror" (entlast) "" stp ept "_y")
		  ) ;_ end of if
		) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  ) ;_ end of if
  (setvar 'CMDECHO old_cmdecho)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

Спс интересная штука.
А можно в код добавить возможность работы с полилинией?
1) Указываем радиус или соглашаемся с тем что установлен
2) Выбираем 2 стороны
3) _explode
(берёт из выделенных сторон, так как это полилиния то хапает всё шо относится к ней)
4) inside_fillet
5) обеденение взорванных объектов в полилинию командой PL-CSE из http://dwg.ru/dnl/607
(обеденяет то шо было выделено ранее + изменения , радиус и прилагаемые 2 линии которые были изменены)
...
или 2-рой вариант если нереално зделать ту последовательность:
1)отметил полилинию тыцнув по ней
2) _explode
3) inside_fillet
4) Указываем радиус или соглашаемся с тем что установлен
5) Выбираем 2 стороны
6) обеденение взорванных объектов в полилинию командой PL-CSE из http://dwg.ru/dnl/607
(обеденяет то шо было выделено ранее + изменения , радиус и прилагаемые 2 линии которые были изменены)

Можно обеденение упростить без PL-CSE, а просто командой Join

Do$ · 27.10.2009, 12:49

Цитата:

Сообщение от Positron

обеденение взорванных объектов в полилинию командой PL-CSE из http://dwg.ru/dnl/607

Тогда уж PL-JOIN лучше...
В принципе и "вручную" не особо накладно:
1. _explode
2. _inside_fillet
3. _pl-join
Будет время и желание - попробую

sbi · 27.10.2009, 12:58

Вот еще вариант ручного ввода- 3 команды- 1мин. работы.
Команда: _circle Центр круга или [3Т/2Т/ККР (кас кас радиус)]:
Команда: _trim
Выберите объекты: найдено: 1, всего: 2
Команда: _join Выберите исходный объект:
Выберите объекты для объединения с источником: найдено: 1
Добавлено сегментов: 1

Positron · 27.10.2009, 13:00

Цитата:

Сообщение от sbi

Вот еще вариант ручного ввода- 3 команды- 1мин. работы.
Команда: _circle Центр круга или [3Т/2Т/ККР (кас кас радиус)]:
Команда: _trim
Выберите объекты: найдено: 1, всего: 2
Команда: _join Выберите исходный объект:
Выберите объекты для объединения с источником: найдено: 1
Добавлено сегментов: 1

именно так щас и работаю

хотелось бы шагнуть к более быстрому методу роботы , 1-ной командой

В верху Кулик Алексей aka kpblc написал ссылку http://dwg.ru/dnl/607
там есть команда
PL-L2A - преобразует линейный сегмент в дуговой
тоисть комбинация команды Chamfer и PL-L2A даёт желаемый результат!, уже проверил...
А теперь хз как оформить в 1 кнопку

Если Do$ поможет буду премного благодарен

sbi · 27.10.2009, 13:12

Читай
http://dwg.ru/art/2

Positron · 27.10.2009, 13:24

Цитата:

Сообщение от Positron

В верху Кулик Алексей aka kpblc написал ссылку http://dwg.ru/dnl/607
там есть команда
PL-L2A - преобразует линейный сегмент в дуговой
тоисть комбинация команды Chamfer и PL-L2A даёт желаемый результат!, уже проверил...

вот первая попытка... токо тут под определённый радиус, можно и убрать заменив 10 косой \
^C^C_Chamfer;d;10;10;;\\_PL-L2A;R;10;\;
...
вот еси б убрать 3-е нажатие типа выделение _Chamfer'ом результата, то было б самое оно

тут я уже пас, хотя ща попробую с выделением придедущего объекта, мож получится.

так непашет... нужен асистанс, команда почти готова, токо как зделать шоб оно распознало изменённую линию , хз как... help
^C^C_Chamfer;d;10;10;;\\ _SELECT;_l;_PL-L2A;R;10;\;

с пустя 20 минут... теперь понял _SELECT;_l; вызывает предедущую команду _Chamfer ... незнаю как вызвать предедущее выделение, кто знает?

+ есть вопрос, данным макросом получилось 1 раз выпуклый радиус, незнаю почему, в файле он с выпуклым и впуклым (рисуя новые прямоугольники получаются всегда впуклые), кому интересно пробуйте макросом, может кто шарит в чом загвостка? интересная штука...

Positron · 28.10.2009, 14:30

Разобрался непашет оно как надо... я так понял шо это из-за направления линий, если рисовать прямоугольник с верхнего левого угла то будет впуклый, а все остальные стороны выпуклый, тоисть сей момент неподходит, решения я не нашел...
себто этот макрос лажа
^C^C_Chamfer;d;10;10;;\\_PL-L2A;R;10;\;
...
первоначальный вариант луче

Цитата:

Сообщение от Do$

Тогда уж PL-JOIN лучше...
В принципе и "вручную" не особо накладно:
1. _explode
2. _inside_fillet
3. _pl-join
Будет время и желание - попробую

Буду ждать Do$'а ... и заранее спасибо

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

Do$ · 28.10.2009, 22:08

Сделано "топорно", но работает:

<<Код удален как не корректно работающий>>

Забавно получается, когда делаешь фаску м/у полилинией и просто линией... В общем, если что - ctrl+z

Jonas · 29.10.2009, 06:38

Любопытно конечео.
А вот с телами, хотя бы в принципе, возможно?

Do$ · 29.10.2009, 08:20

Что имеется в виду? делать на грани "фаску наоборот"? Если об этом речь, то примерно так может получиться (не уверен, так как давно с 3Д не имел дела):
- берем солид с гранью
- вдоль нужной грани выдавливаем цилиндр
- вычитаем цилиндр из солида.

Jonas · 29.10.2009, 10:23

Цитата:

Сообщение от Do$

Что имеется в виду? делать на грани "фаску наоборот"? Если об этом речь, то примерно так может получиться (не уверен, так как давно с 3Д не имел дела):

Да, именно это.

Цитата:

Сообщение от Do$

- берем солид с гранью
- вдоль нужной грани выдавливаем цилиндр
- вычитаем цилиндр из солида.

Имел в виду с применением команды Fillet.

Do$ · 29.10.2009, 12:26

Цитата:

Сообщение от Jonas

Имел в виду с применением команды Fillet.

Мне не очень понятно, зачем так извращаться

. Но предположим, чисто теоретически:
- Делаем фаску грани коммандой fillet
- Можно потом копировать получившуюся скругление (Copy faces)
- Развернуть эту поверхность внутрь тела.
- Каким-нибудь хитрым способом обрезать солид по этой поверхности

А если грань не прямолинейная? "Вывернуть" поверхность? Что-то мне кажется, что акад такого не умеет...
Вообще, я считаю, очень повезло, что он умеет просто фаску снимать с солидов.

Zouss · 29.10.2009, 14:53

простейший lisp, который "выворачивает" наизнанку уже нарисованные дуги
выделенный цветом фрагмент можно использовать как часть более серьезной проги

Код:

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

(defun c:revertar (/ dx50 dx51 ed)

  (setq	ed   (entget (ssname (ssget ":S" ) 0))
	dx50 (assoc 50 ed)
	dx51 (assoc 51 ed)
	ed   (subst (cons 50 (cdr dx51)) dx50 ed)
	ed   (subst (cons 51 (cdr dx50)) dx51 ed)
  )
  (entmod ed)

  (princ)
) ;_  defun

Positron · 30.10.2009, 11:24

Цитата:

Сообщение от Do$

Сделано "топорно", но работает:

Код:

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

(defun c:inside_fillet
       (/ ent1 ent2 obj tmp pt_lst ent_lst)
  (vl-load-com)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
  (setq old_cmdecho (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (while (and
	   (/= ent1 "Cancel")
	   (not (vl-catch-all-error-p ent1))
	   (not (vl-catch-all-error-p ent2))
	   (not	(and
		  (listp ent1)
		  (listp ent2)
		  (= (type (car ent1)) 'ENAME)
		  (= (type (car ent2)) 'ENAME)
		) ;_ end of and
	   ) ;_ end of not
	 ) ;_ end of and
    (if	ent1
      (progn
	(cond
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Radius")
	   ) ;_ end of and
	   (initget (+ 4 128))
	   (if (setq
		 ent1 nil
		 rad
		      (getdist (strcat "\nРадиус внутреннего скругления:<"
				       (rtos (getvar 'FILLETRAD) 2 4)
				       ">"
			       ) ;_ end of strcat
		      ) ;_ end of getdist
	       ) ;_ end of setq
	     (setvar 'FILLETRAD rad)
	     (princ (rtos (getvar 'FILLETRAD) 2 4))
	   ) ;_ end of if
	  )
	  ((and (listp ent1) (= (type (car ent1)) 'ENAME))
	   (setq ent2
		  (vl-catch-all-apply
		    (function (lambda () (entsel "\nУкажите второй объект:")))
		  ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	  )
	) ;_ end of cond
      ) ;_ end of progn
      (progn
	(initget "Радиус Отмена _Radius Cancel")
	(if
	  (not
	    (setq
	      ent1
	       (vl-catch-all-apply
		 (function
		   (lambda ()
		     (entsel
		       "\nУкажите первый объект, или:<Отмена>[Радиус/ Отмена]"
		     ) ;_ end of entsel
		   ) ;_ end of lambda
		 ) ;_ end of function
	       ) ;_ end of vl-catch-all-apply
	    ) ;_ end of setq
	  ) ;_ end of not
	   (setq ent1 "Cancel")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while
  (if (and
	(listp ent1)
	(listp ent2)
	(= (type (car ent1)) 'ENAME)
	(= (type (car ent2)) 'ENAME)
      ) ;_ end of and
    (progn
      (cond
	((and (eq (car ent1) (car ent2))
	      (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	 ) ;_ end of and
	 (progn
	   (setq pt_lst	 (mapcar
			   '(lambda (x)
			      (vlax-curve-getclosestpointto
				(setq
				  obj (vlax-ename->vla-object (car ent1))
				) ;_ end of setq
				x
			      ) ;_ end of vlax-curve-getclosestpointto
			    ) ;_ end of lambda
			   (list (cadr ent1) (cadr ent2))
			 ) ;_ end of mapcar
		 ent_lst (vlax-safearray->list
			   (vlax-variant-value (vla-explode obj))
			 ) ;_ end of vlax-safearray->list
		 tmp	 (entdel (car ent1))
		 ent1	 (list (vlax-vla-object->ename
				 (car
				   (vl-remove-if
				     '(lambda (x)
					(not
					  (vlax-curve-getParamAtPoint
					    x
					    (car pt_lst)
					  ) ;_ end of vlax-curve-getParamAtPoint
					) ;_ end of not
				      ) ;_ end of lambda
				     ent_lst
				   ) ;_ end of vl-remove-if
				 ) ;_ end of car
			       ) ;_ end of vlax-vla-object->ename
			 ) ;_ end of list
		 ent2	 (list (vlax-vla-object->ename
				 (car
				   (vl-remove-if
				     '(lambda (x)
					(not (vlax-curve-getParamAtPoint
					       x
					       (cadr pt_lst)
					     ) ;_ end of vlax-curve-getParamAtPoint
					) ;_ end of not
				      ) ;_ end of lambda
				     ent_lst
				   ) ;_ end of vl-remove-if
				 ) ;_ end of car
			       ) ;_ end of vlax-vla-object->ename
			 ) ;_ end of list
	   ) ;_ end of setq
	 ) ;_ end of progn
	)
      ) ;_ end of cond
      (vl-catch-all-apply
	(function
	  (lambda (/ stp ept arc ss)
	    (vl-cmdf "_.fillet" (car ent1) (car ent2))
	    (if	(= (getvar 'FILLETRAD) 0)
	      (if ent_lst
		(progn
		  (setq ss (ssadd))
		  (while ent_lst
		    (ssadd (vlax-vla-object->ename (car ent_lst)) ss)
		    (setq ent_lst (cdr ent_lst))
		  ) ;_ end of while
		  (if (not C:PL-JOIN)
		    (load "pltools")
		  ) ;_ end of if
		  (sssetfirst nil ss)
		  (vl-cmdf (c:pl-join))
		) ;_ end of progn
	      ) ;_ end of if
	      (progn
		(setq arc (vlax-ename->vla-object (entlast))
		      stp (vlax-curve-getStartPoint arc)
		      ept (vlax-curve-getEndPoint arc)
		) ;_ end of setq
		(vl-cmdf "_.mirror" (setq arc (entlast)) "" stp ept "_y")
		(if ent_lst
		  (progn
		    (setq ss (ssadd (entlast)))
		    (while ent_lst
		      (ssadd (vlax-vla-object->ename (car ent_lst)) ss)
		      (setq ent_lst (cdr ent_lst))
		    ) ;_ end of while
		    (if	(not C:PL-JOIN)
		      (load "pltools")
		    ) ;_ end of if
		    (sssetfirst nil ss)
		    (vl-cmdf (c:pl-join))
		  ) ;_ end of progn
		) ;_ end of if
	      ) ;_ end of progn
	    ) ;_ end of if
	  ) ;_ end of lambda
	) ;_ end of function
      ) ;_ end of vl-catch-all-apply
    ) ;_ end of progn
  ) ;_ end of if
  (setvar 'CMDECHO old_cmdecho)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

Забавно получается, когда делаешь фаску м/у полилинией и просто линией... В общем, если что - ctrl+z

СПАСИБО!

Do$ · 30.10.2009, 13:22

Zouss, выворачивает, согласен

Но немного не так, как хотелось бы.
Для сравнения (после загрузки запускать коммандой ma_test):

Код:

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

(defun mirror_arc (ent)
  (if (and ent (= (cdr (assoc 0 (setq ent (entget ent)))) "ARC"))
    (entmod
      (append
	(list
	  (assoc -1 ent)
	  (cons
	    10
	    (apply
	      '(lambda (u v)
		 (polar u (angle u v) (* 2 (distance v u)))
	       ) ;_ end of lambda
	      (list
		(cdr (assoc 10 ent))
		(apply
		  '(lambda (a b)
		     (mapcar '(lambda (c d) (/ (+ c d) 2)) a b)
		   ) ;_ end of lambda
		  (mapcar
		    '(lambda (m)
		       (polar (cdr (assoc 10 ent))
			      m
			      (cdr (assoc 40 ent))
		       ) ;_ end of polar
		     ) ;_ end of lambda
		    (mapcar '(lambda (n) (cdr (assoc n ent)))
			    '(50 51)
		    ) ;_ end of mapcar
		  ) ;_ end of mapcar
		) ;_ end of apply
	      ) ;_ end of list
	    ) ;_ end of apply
	  ) ;_ end of cons
	) ;_ end of list
	(mapcar	'(lambda (k) (cons k (+ (cdr (assoc k ent)) pi)))
		'(50 51)
	) ;_ end of mapcar
      ) ;_ end of append
    ) ;_ end of entmod
  ) ;_ end of if
) ;_  defun


(defun c:ma_test (/ sel)
  (setq	sel
	 (vl-catch-all-apply
	   '(lambda () (mirror_arc (car (entsel "\nУкажите дугу:"))))
	 ) ;_ end of vl-catch-all-apply
  ) ;_ end of setq
  (cond
    ((and (listp sel) (= (length sel) 4))
     (princ "\nДуга удачно перевернута")
    )
    ((vl-catch-all-error-p sel)
     (princ "\nРабота программы прервана")
    )
    ((not sel)
     (princ "\nНичего не указано или указанное не является дугой"
     ) ;_ end of princ
    )
  ) ;_ end of cond
  (princ)
) ;_ end of defun

Positron, исправил некоторые косяки в программе, теперь стабильнее работать будет (предыдущая версия немного опасна - когда делаешь скругление между линией и полилинией, мало того, что оно получается не "вовнутрь", программа еще переворачивает последнюю начерченную линию.)
Исправленный вариант:

Код:

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

(defun c:inside_fillet
       (/ ent1 ent2 rad obj tmp pt_lst ent_lst mirror_arc mod old_cmdecho)

  (defun mirror_arc (ent)
    (if	(= (cdr (assoc 0 (setq ent (entget ent)))) "ARC")
      (entmod
	(append
	  (list
	    (assoc -1 ent)
	    (cons
	      10
	      (apply
		'(lambda (u v)
		   (polar u (angle u v) (* 2 (distance v u)))
		 ) ;_ end of lambda
		(list
		  (cdr (assoc 10 ent))
		  (apply
		    '(lambda (a b)
		       (mapcar '(lambda (c d) (/ (+ c d) 2)) a b)
		     ) ;_ end of lambda
		    (mapcar
		      '(lambda (m)
			 (polar	(cdr (assoc 10 ent))
				m
				(cdr (assoc 40 ent))
			 ) ;_ end of polar
		       ) ;_ end of lambda
		      (mapcar '(lambda (n) (cdr (assoc n ent)))
			      '(50 51)
		      ) ;_ end of mapcar
		    ) ;_ end of mapcar
		  ) ;_ end of apply
		) ;_ end of list
	      ) ;_ end of apply
	    ) ;_ end of cons
	  ) ;_ end of list
	  (mapcar '(lambda (k) (cons k (+ (cdr (assoc k ent)) pi)))
		  '(50 51)
	  ) ;_ end of mapcar
	) ;_ end of append
      ) ;_ end of entmod
    ) ;_ end of if
  ) ;_  defun
  (vl-load-com)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
  (setq old_cmdecho (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (princ (strcat "\nТекущий радиус скругления:"
		 (rtos (getvar 'FILLETRAD) 2 4)
		 ". Текущий режим обрезки:"
		 (if (= (getvar 'TRIMMODE) 1)
		   "\"Обрезать концы\""
		   "\"Не обрезать концы\""
		 ) ;_ end of if
	 ) ;_ end of strcat
  ) ;_ end of princ
  (while (and
	   (/= ent1 "Cancel")
	   (not (vl-catch-all-error-p ent1))
	   (not (vl-catch-all-error-p ent2))
	   (not (vl-catch-all-error-p rad))
	   (not	(and
		  (listp ent1)
		  (listp ent2)
		  (= (type (car ent1)) 'ENAME)
		  (= (type (car ent2)) 'ENAME)
		) ;_ end of and
	   ) ;_ end of not
	 ) ;_ end of and
    (if	ent1
      (progn
	(cond
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Radius")
	   ) ;_ end of and
	   (initget (+ 4 128))
	   (cond
	     ((and (setq
		     ent1 nil
		     rad  (vl-catch-all-apply
			    '(lambda ()
			       (getdist
				 (strcat "\nРадиус внутреннего скругления:<"
					 (rtos (getvar 'FILLETRAD) 2 4)
					 ">"
				 ) ;_ end of strcat
			       ) ;_ end of getdist
			     ) ;_ end of lambda
			  ) ;_ end of vl-catch-all-apply
		   ) ;_ end of setq
		   (not (vl-catch-all-error-p rad))
	      ) ;_ end of and
	      (setvar 'FILLETRAD rad)
	     )
	     ((not rad)
	      (princ (rtos (getvar 'FILLETRAD) 2 4))
	     )
	   ) ;_ end of if
	  )
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Mode")
	   ) ;_ end of and
	   (initget "Да Нет _Yes No")
	   (setq ent1 nil
		 mod  (vl-catch-all-apply
			'(lambda ()
			   (getkword (strcat "Обрезать концы?:<"
					     (if (= (getvar 'TRIMMODE) 1)
					       "Да"
					       "Нет"
					     ) ;_ end of if
					     ">[Да/ Нет]"
				     ) ;_ end of strcat
			   ) ;_ end of getkword
			 ) ;_ end of lambda
		      ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	   (cond
	     ((or (and (= (type mod) 'STR) (= mod "Yes"))
		  (not mod)
	      ) ;_ end of or
	      (setvar 'TRIMMODE 1)
	     )
	     ((and (= (type mod) 'STR) (= mod "No"))
	      (setvar 'TRIMMODE 0)
	     )
	   ) ;_ end of cond
	  )
	  ((and (listp ent1) (= (type (car ent1)) 'ENAME))
	   (setq ent2
		  (vl-catch-all-apply
		    (function (lambda () (entsel "\nУкажите второй объект:")))
		  ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	  )
	) ;_ end of cond
      ) ;_ end of progn
      (progn
	(initget "Радиус реЖим Отмена _Radius Mode Cancel")
	(if
	  (or
	    (vl-catch-all-error-p rad)
	    (vl-catch-all-error-p mod)
	    (not
	      (setq
		ent1
		 (vl-catch-all-apply
		   (function
		     (lambda ()
		       (entsel
			 "\nУкажите первый объект, или:<Отмена>[Радиус/ реЖим/ Отмена]"
		       ) ;_ end of entsel
		     ) ;_ end of lambda
		   ) ;_ end of function
		 ) ;_ end of vl-catch-all-apply
	      ) ;_ end of setq
	    ) ;_ end of not
	  ) ;_ end of or
	   (setq ent1 "Cancel")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while
  (if (and
	(listp ent1)
	(listp ent2)
	(= (type (car ent1)) 'ENAME)
	(= (type (car ent2)) 'ENAME)
      ) ;_ end of and
    (cond
      (
       (and (eq (car ent1) (car ent2))
	    (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	    (or c:pl-join (/= (load "pltools" "Not") "Not"))
       ) ;_ end of and
       (progn
	 (setq pt_lst  (mapcar
			 '(lambda (x)
			    (vlax-curve-getclosestpointto
			      (setq
				obj (vlax-ename->vla-object (car ent1))
			      ) ;_ end of setq
			      x
			    ) ;_ end of vlax-curve-getclosestpointto
			  ) ;_ end of lambda
			 (list (cadr ent1) (cadr ent2))
		       ) ;_ end of mapcar
	       ent_lst (vlax-safearray->list
			 (vlax-variant-value (vla-explode obj))
		       ) ;_ end of vlax-safearray->list
	       ent1    (progn
			 (entdel (car ent1))
			 (list (vlax-vla-object->ename
				 (car
				   (vl-remove-if
				     '(lambda (x)
					(not
					  (vlax-curve-getParamAtPoint
					    x
					    (car pt_lst)
					  ) ;_ end of vlax-curve-getParamAtPoint
					) ;_ end of not
				      ) ;_ end of lambda
				     ent_lst
				   ) ;_ end of vl-remove-if
				 ) ;_ end of car
			       ) ;_ end of vlax-vla-object->ename
			       (car pt_lst)
			 ) ;_ end of list
		       ) ;_ end of progn
	       ent2    (list (vlax-vla-object->ename
			       (car
				 (vl-remove-if
				   '(lambda (x)
				      (not (vlax-curve-getParamAtPoint
					     x
					     (cadr pt_lst)
					   ) ;_ end of vlax-curve-getParamAtPoint
				      ) ;_ end of not
				    ) ;_ end of lambda
				   ent_lst
				 ) ;_ end of vl-remove-if
			       ) ;_ end of car
			     ) ;_ end of vlax-vla-object->ename
			     (cadr pt_lst)
		       ) ;_ end of list
	 ) ;_ end of setq
	 (vl-catch-all-apply
	   (function
	     (lambda (/ ss)
	       (vl-cmdf "_.fillet" ent1 ent2)
	       (if (= (getvar 'FILLETRAD) 0)
		 (setq ss (ssadd))
		 (setq ss (ssadd (cdar (mirror_arc (entlast)))))
	       ) ;_ end of if
	       (while ent_lst
		 (ssadd	(vlax-vla-object->ename (car ent_lst))
			ss
		 ) ;_ end of ssadd
		 (setq ent_lst (cdr ent_lst))
	       ) ;_ end of while
	       (sssetfirst nil ss)
	       (vl-cmdf (c:pl-join))
	     ) ;_ end of lambda
	   ) ;_ end of function
	 ) ;_ end of vl-catch-all-apply
       ) ;_ end of progn
      )
      ((and
	 (not (eq (car ent1) (car ent2)))
	 (not
	   (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	 ) ;_ end of not
	 (not
	   (wcmatch (cdr (assoc 0 (entget (car ent2)))) "*POLYLINE")
	 ) ;_ end of not
       ) ;_ end of and
       (vl-catch-all-apply
	 '(lambda ()
	    (vl-cmdf "_.fillet" ent1 ent2)
	    ((/= (getvar 'FILLETRAD) 0) (mirror_arc (entlast)))
	  ) ;_ end of lambda
       ) ;_ end of vl-catch-all-apply
      )
      (T
       (princ
	 "\nСоздание \"вогнутого скругления\" с выбранными объектами невозможно"
       ) ;_ end of princ
      )
    ) ;_ end of cond
  ) ;_ end of if
  (setvar 'CMDECHO old_cmdecho)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

Positron · 30.10.2009, 16:50

Цитата:

Сообщение от Do$

Positron, исправил некоторые косяки в программе, теперь стабильнее работать будет (предыдущая версия немного опасна - когда делаешь скругление между линией и полилинией, мало того, что оно получается не "вовнутрь", программа еще переворачивает последнюю начерченную линию.)

Спасиб.

Positron · 11.11.2009, 14:03

Юзал и столкнулся с моментом когда скруглял полилинию и линию...
"Создание "вогнутого скругления" с выбранными объектами невозможно"
...
А можно добавить что б оно как у fillet было (но вогнутым естественно) обедняло выделенную линию с полелиниией... ?

Do$ · 11.11.2009, 16:39

Цитата:

Сообщение от Positron

столкнулся с моментом когда скруглял полилинию и линию

Между двумя полилиниями и во всех возможных сочетаниях "полилиния-любая линия" тоже не сработает.

Предлагаю перед inside_fillet использовать _explode на полилинию или _pl-join на линию и полилинию или _fillet с нулевым радиусом на оба примитива.
P.S.

Цитата:

_fillet с нулевым радиусом на оба примитива...

А ведь это мысль!

Пробуй:

Код:

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

(defun c:inside_fillet
		       (/	 ent1	  ent2	   rad	    obj
			tmp	 pt_lst	  ent_lst  mirror_arc
			mod	 old_cmdecho	   frp
		       )

  (defun mirror_arc (ent)
    (if	(= (cdr (assoc 0 (setq ent (entget ent)))) "ARC")
      (entmod
	(append
	  (list
	    (assoc -1 ent)
	    (cons
	      10
	      (apply
		'(lambda (u v)
		   (polar u (angle u v) (* 2 (distance v u)))
		 ) ;_ end of lambda
		(list
		  (cdr (assoc 10 ent))
		  (apply
		    '(lambda (a b)
		       (mapcar '(lambda (c d) (/ (+ c d) 2)) a b)
		     ) ;_ end of lambda
		    (mapcar
		      '(lambda (m)
			 (polar	(cdr (assoc 10 ent))
				m
				(cdr (assoc 40 ent))
			 ) ;_ end of polar
		       ) ;_ end of lambda
		      (mapcar '(lambda (n) (cdr (assoc n ent)))
			      '(50 51)
		      ) ;_ end of mapcar
		    ) ;_ end of mapcar
		  ) ;_ end of apply
		) ;_ end of list
	      ) ;_ end of apply
	    ) ;_ end of cons
	  ) ;_ end of list
	  (mapcar '(lambda (k) (cons k (+ (cdr (assoc k ent)) pi)))
		  '(50 51)
	  ) ;_ end of mapcar
	) ;_ end of append
      ) ;_ end of entmod
    ) ;_ end of if
  ) ;_  defun
  (vl-load-com)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
  (setq old_cmdecho (getvar 'CMDECHO))
  (setvar 'CMDECHO 0)
  (princ (strcat "\nТекущий радиус скругления:"
		 (rtos (getvar 'FILLETRAD) 2 4)
		 ". Текущий режим обрезки:"
		 (if (= (getvar 'TRIMMODE) 1)
		   "\"Обрезать концы\""
		   "\"Не обрезать концы\""
		 ) ;_ end of if
	 ) ;_ end of strcat
  ) ;_ end of princ
;;;  (setq ent1 nil ent2 nil)
  (while (and
	   (/= ent1 "Cancel")
	   (not (vl-catch-all-error-p ent1))
	   (not (vl-catch-all-error-p ent2))
	   (not (vl-catch-all-error-p rad))
	   (not	(and
		  (listp ent1)
		  (listp ent2)
		  (= (type (car ent1)) 'ENAME)
		  (= (type (car ent2)) 'ENAME)
		) ;_ end of and
	   ) ;_ end of not
	 ) ;_ end of and
    (if	ent1
      (progn
	(cond
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Radius")
	   ) ;_ end of and
	   (initget (+ 4 128))
	   (cond
	     ((and (setq
		     ent1 nil
		     rad  (vl-catch-all-apply
			    '(lambda ()
			       (getdist
				 (strcat "\nРадиус внутреннего скругления:<"
					 (rtos (getvar 'FILLETRAD) 2 4)
					 ">"
				 ) ;_ end of strcat
			       ) ;_ end of getdist
			     ) ;_ end of lambda
			  ) ;_ end of vl-catch-all-apply
		   ) ;_ end of setq
		   (not (vl-catch-all-error-p rad))
	      ) ;_ end of and
	      (setvar 'FILLETRAD rad)
	     )
	     ((not rad)
	      (princ (rtos (getvar 'FILLETRAD) 2 4))
	     )
	   ) ;_ end of if
	  )
	  ((and	(= (type ent1) 'STR)
		(= ent1 "Mode")
	   ) ;_ end of and
	   (initget "Да Нет _Yes No")
	   (setq ent1 nil
		 mod  (vl-catch-all-apply
			'(lambda ()
			   (getkword (strcat "Обрезать концы?:<"
					     (if (= (getvar 'TRIMMODE) 1)
					       "Да"
					       "Нет"
					     ) ;_ end of if
					     ">[Да/ Нет]"
				     ) ;_ end of strcat
			   ) ;_ end of getkword
			 ) ;_ end of lambda
		      ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	   (cond
	     ((or (and (= (type mod) 'STR) (= mod "Yes"))
		  (not mod)
	      ) ;_ end of or
	      (setvar 'TRIMMODE 1)
	     )
	     ((and (= (type mod) 'STR) (= mod "No"))
	      (setvar 'TRIMMODE 0)
	     )
	   ) ;_ end of cond
	  )
	  ((and (listp ent1) (= (type (car ent1)) 'ENAME))
	   (setq ent2
		  (vl-catch-all-apply
		    (function (lambda () (entsel "\nУкажите второй объект:")))
		  ) ;_ end of vl-catch-all-apply
	   ) ;_ end of setq
	  )
	) ;_ end of cond
      ) ;_ end of progn
      (progn
	(initget "Радиус реЖим Отмена _Radius Mode Cancel")
	(if
	  (or
	    (vl-catch-all-error-p rad)
	    (vl-catch-all-error-p mod)
	    (not
	      (setq
		ent1
		 (vl-catch-all-apply
		   (function
		     (lambda ()
		       (entsel
			 "\nУкажите первый объект, или:<Отмена>[Радиус/ реЖим/ Отмена]"
		       ) ;_ end of entsel
		     ) ;_ end of lambda
		   ) ;_ end of function
		 ) ;_ end of vl-catch-all-apply
	      ) ;_ end of setq
	    ) ;_ end of not
	  ) ;_ end of or
	   (setq ent1 "Cancel")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  ) ;_ end of while
  (if (and
	(listp ent1)
	(listp ent2)
	(= (type (car ent1)) 'ENAME)
	(= (type (car ent2)) 'ENAME)
      ) ;_ end of and
    (cond
      (
       (or
	 (and (eq (car ent1) (car ent2))
	      (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	      (or c:pl-join (/= (load "pltools" "Not") "Not"))
	 ) ;_ end of and
	 (and
	   (not (eq (car ent1) (car ent2)))
	   (or (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	       (wcmatch (cdr (assoc 0 (entget (car ent2)))) "*POLYLINE")
	   ) ;_ end of or
                (or c:pl-join (/= (load "pltools" "Not") "Not"))
	 ) ;_ end of and
       ) ;_ end of or
       (progn
	 (if
	   (and
	     (not (eq (car ent1) (car ent2)))
	     (or
	       (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	       (wcmatch (cdr (assoc 0 (entget (car ent2)))) "*POLYLINE")
	     ) ;_ end of or
	   ) ;_ end of and
	    (progn
	      (setq frp (getvar 'FILLETRAD))
	      (setvar 'FILLETRAD 0)
	      (vl-cmdf "_.fillet" ent1 ent2)
	      (vl-cmdf)
	      (setvar 'FILLETRAD frp)
	      (if
		(or
		  (not (entupd (car ent1)))
		  (not (entupd (car ent2)))
		) ;_ end of or
		 (if (not (entupd (car ent1)))
		   (setq ent1 (list (car ent2) (cadr ent1)))
		 ) ;_ end of if
		 (progn
		   (princ
		     "\nСоздание скругления с выбранными объектами невозможно"
		   ) ;_ end of princ
		   (setq ent1 nil)
		 ) ;_ end of progn
	      ) ;_ end of if
	    ) ;_ end of progn
	 ) ;_ end of if
	 (if ent1
	   (progn
	     (setq pt_lst  (mapcar
			     '(lambda (x)
				(vlax-curve-getclosestpointto
				  (setq
				    obj	(vlax-ename->vla-object (car ent1))
				  ) ;_ end of setq
				  x
				) ;_ end of vlax-curve-getclosestpointto
			      ) ;_ end of lambda
			     (list (cadr ent1) (cadr ent2))
			   ) ;_ end of mapcar
		   ent_lst (vlax-safearray->list
			     (vlax-variant-value (vla-explode obj))
					;!!!
			   ) ;_ end of vlax-safearray->list
		   ent1	   (progn
			     (entdel (car ent1))
			     (list (vlax-vla-object->ename
				     (car
				       (vl-remove-if
					 '(lambda (x)
					    (not
					      (vlax-curve-getParamAtPoint
						x
						(car pt_lst)
					      ) ;_ end of vlax-curve-getParamAtPoint
					    ) ;_ end of not
					  ) ;_ end of lambda
					 ent_lst
				       ) ;_ end of vl-remove-if
				     ) ;_ end of car
				   ) ;_ end of vlax-vla-object->ename
				   (car pt_lst)
			     ) ;_ end of list
			   ) ;_ end of progn
		   ent2	   (list (vlax-vla-object->ename
				   (car
				     (vl-remove-if
				       '(lambda	(x)
					  (not (vlax-curve-getParamAtPoint
						 x
						 (cadr pt_lst)
					       ) ;_ end of vlax-curve-getParamAtPoint
					  ) ;_ end of not
					) ;_ end of lambda
				       ent_lst
				     ) ;_ end of vl-remove-if
				   ) ;_ end of car
				 ) ;_ end of vlax-vla-object->ename
				 (cadr pt_lst)
			   ) ;_ end of list
	     ) ;_ end of setq
	     (vl-catch-all-apply
	       (function
		 (lambda (/ ss)
		   (vl-cmdf "_.fillet" ent1 ent2)
		   (if (= (getvar 'FILLETRAD) 0)
		     (setq ss (ssadd))
		     (setq ss (ssadd (cdar (mirror_arc (entlast)))))
		   ) ;_ end of if
		   (while ent_lst
		     (ssadd (vlax-vla-object->ename (car ent_lst))
			    ss
		     ) ;_ end of ssadd
		     (setq ent_lst (cdr ent_lst))
		   ) ;_ end of while
		   (sssetfirst nil ss)
		   (vl-cmdf (c:pl-join))
		 ) ;_ end of lambda
	       ) ;_ end of function
	     ) ;_ end of vl-catch-all-apply
	   ) ;_ end of progn
	 ) ;_ end of if
       ) ;_ end of progn
      )
      ((and
	 (not (eq (car ent1) (car ent2)))
	 (not
	   (wcmatch (cdr (assoc 0 (entget (car ent1)))) "*POLYLINE")
	 ) ;_ end of not
	 (not
	   (wcmatch (cdr (assoc 0 (entget (car ent2)))) "*POLYLINE")
	 ) ;_ end of not
       ) ;_ end of and
       (vl-catch-all-apply
	 '(lambda ()
	    (vl-cmdf "_.fillet" ent1 ent2)
	    ((/= (getvar 'FILLETRAD) 0) (mirror_arc (entlast)))
	  ) ;_ end of lambda
       ) ;_ end of vl-catch-all-apply
      )
      (T
       (princ
	 "\nСоздание скругления с выбранными объектами невозможно"
       ) ;_ end of princ
      )
    ) ;_ end of cond
  ) ;_ end of if
  (setvar 'CMDECHO old_cmdecho)
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

Dobrolet · 03.02.2010, 14:02

А возможно ли доработать и для тел (делать на ребрах)

.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Минимальный радиус кривизны пути монорельса	Дмитрий_М	Конструкции зданий и сооружений	23	22.02.2018 14:57
как задать точный радиус полилинии?	uyka	AutoCAD	18	12.10.2009 13:46