[VVA]

Данный набор программ является коллективным продуктом участников форумов autocad.ru и dwg.ru с моими доработками.
Захотелось собрать все программы для работы с полилиниями воедино и оформить как полагается.

=========== Доступные команды PLTOOLS=================
Редакция 17.06.2014
PL-JOIN -Объединение выбранных полилиний
PL-VFI -вставка вершин в выбранной полилинии в местах пересечения с
указанными полилиниями, линиями, дугами
PL-JOIN3D -Объединение 3D полилиний
PL-A2L -Замена линейного сегмента в полилинии дуговым сегментом.
PL-L2A -Замена дугового сегмента в полилинии линейным сегментом.
PL-DIV -Разбивает выбранный сегмент полилинии на указанное количество
сегментов или через указанное расстояние
PL-DIVAll -Разбивает все сегменты полилинии на указанное количество
сегментов или через указанное расстояние
PL-VxAdd -Добавляет новую вершину к полилинии
ENTREVS -Реверс объекта
ENTREV -Реверс объектов (множественный выбор)
PL-CW -Реверс выбранных полилиний по часовой стрелке
PL-CCW -Реверс выбранных полилиний против часовой стрелки
PL-VxRdc -Удаление вершин полилиний, которые лежат на одной прямой
PL-VxDel -Удаление выбранной вершины
pl-VxOpt -Удаление совпадающих вершин из полилинии
PL-NoArc -Аппроксимация дуговых сегментов полилинии
PL-Clone -Построение полилинии путем копирования ее сегментов
PL-VxMove -Перемещение вершин полилинии
PL-Vx1 -Изменение начала полилинии
ConvTo2d -Преобразование линейных объектов в 2D полилинии
ConvTo3d -Преобразование линейных объектов в 3D полилинии
MPL -Построение средней линии Более продвинутая версия Rollin_Ball.lsp Find MidBoundary between two polylines.
R3P -Прямоугольгик по 3-м точкам
PL-P90 -Рисование перпендикулярных друг к другу сегментов полилинии
PL-CSE -Объединение 2d полилиний по примитиву
PL-SgWidth -Изменить ширину сегмента полилинии

Реверс дуговых сегментов полилинии из #79
На дуговых сегментах полилинии тип линий может быть "вверх тормашками", причем реверс не помогает. Этот артефакт можно побороть, если в полилинии включить "генерацию типа линий".

Панели, лисп и инструкции здесь http://dwg.ru/dnl/607
Обсуждаем, критикуем, предлагаем

[Profan]

Щас посмотрим.

[Profan]

Маленькое уточнение.
Можно было бы написать в благодарностях
Владимир Громов aka Profan.

[VVA]

Не знал, исправлю.

[Profan]

Замечания к программам (командам).

"Добавить новую вершину в полилинию."
Не обрабатывается нажатие правой кнопки мыши. В программе предполагается, что новую вершину мы куда-то переместим мышью. но если нам не надо перемещать вершину, а подтвердить уже указанную точку, то напрашивается нажатие правой кнопки мыши и вот тут программа срывается. По-моему, kpblc дорабатывал эту программу.

"Удалить вершину полилинии".
Результат может оказаться непредсказуемым, если удаляется вершина между линейным и дуговым сегментами. В зависимости от направления полилинии вместе с вершиной удаляется или дуговой или линейный сегмент.

"Аппроксимация дуговых сегментов линейными".
В русской версии не работает контекстное меню.

[Кулик Алексей aka kpblc]

Дорабатывал, но не добил. Stretch все равно слетает черт-те куда. Там на оригинальном адресе, по-моему, Евгений Елпанов показывал обработку. Его вариант, насколько мне помнится, работал более устойчиво.

[VVA]

"Добавить новую вершину в полилинию." Не обрабатывается нажатие правой кнопки мыши "Аппроксимация дуговых сегментов линейными". В русской версии не работает контекстное меню.

Исправлено грузить с VVA №1

"Удалить вершину полилинии". Результат может оказаться непредсказуемым

По моему очевидно. Если до удаляемой вершины был дуговой сегмент, а после удаляемой линейный, то новый сохранит кривизну и наоборот.
Другое дело, что тот кто удаляет вершину должен отдавать себе отчет как направлена полилиния. Но как помочь ему в этом [sm2100] >kpblc В результате плотного общения с Лентяем, доработавшего код Евгения Елпанова, удалось добиться главного: избавиться от _break (полилинии не теряют ассоциативность). В этой версии вершины добавляются без _strech (там основная сложность была в пересчете bulge), что на мой взгляд более корректно.

[Юрий Water Jet]

"Аппроксимация дуговых сегментов линейными".

Как сделать следующее:
Есть полилиния состоящая из нескольких прямых и дуг с разными радиусами до 500 мм и более 500 мм.
Надо аппроксимировать дуги с радиусом более 500 мм с отклонением 0.1 мм.

[VVA]

Я бы сделал так:
1. _break в точке ->Выделить дуговые сегменты с радиусом более 500 мм в отдельные полилинии (вариант: скопировать полилинию и обрезать)
2. Аппроксимировать их с отклонением 0.1 (имеется ввиду предельное отклонение хорды, т.е. высота стрелки дуги)
3. PL-JOIN собрать все обратно в полилинию
4. При необходимости ENTREVS задать нужный порядок обхода

[Юрий Water Jet]

Так и делаю, но это очень долго. Уходят часы и дни на обработку нескольких полилиний.
Хотелось бы автоматически.
Задать радиус дуги болше которого полилиния должна обрабатываться и отклонение.

[VVA]

>Юрий Water Jet Сделал, пробуй по ссылке с поста №1

[Елпанов Евгений]

Решил тоже добавить код в копилку...
Программа аппроксимирует дуговые сегменты полилинии по заданной высоте, т.е я использую подобный код для генерации векторной картинки полилинии в диалоговых окнах, задавая максимальную высоту в один пиксел.
Предложенная программа только пример, никакой оптимизации...
Я ее наспех выдернул из другого кода и слегка адаптировал для форума...

Код:

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

(defun c:lw-apr (/ A A1 E H I L LST P R)
  ;;  ElpanovEvgeniy, Russia, Moscow, 2006
  ;;  Example of creation of a polyline with the аррrоximаted arc segments
  ;; (c:lw-apr)
  (if (and (setq e (car (entsel)))
           (= (cdr (assoc 0 (entget e))) "LWPOLYLINE")
           (setq h (getdist "\nУкажите максимальную высоту аппроксимируемой дуги. "))
      ) ;_  and
    (progn
      (setq p   0
            lst (list (vlax-curve-getStartPoint e))
      ) ;_  setq
      (repeat (- (cdr (assoc 90 (entget e))) (abs (1- (cdr (assoc 70 (entget e))))))
        (if (setq r (vlax-curve-getSecondDeriv e p))
          (if (equal r '(0 0 0) 1e-8)
            (setq lst (cons (vlax-curve-getPointAtParam e p) lst)
                  p   (1+ p)
            ) ;_  setq
            (progn
              (setq r  (distance '(0 0) (vlax-curve-getFirstDeriv e p))
                    p  (1+ p)
                    i  (/ (- r h) r)
                    l  (* r (atan (sqrt (abs (- 1. (* i i)))) i) 2)
                    a1 (vlax-curve-getDistAtParam e p)
                    a  (vlax-curve-getDistAtParam e (1- p))
                    l  (/ (- a1 a) (1+ (fix (/ (- a1 a) l))))
              ) ;_  setq
              (while (and (< a a1) (not (equal a a1 1e-8)))
                (setq lst (cons (vlax-curve-getPointAtDist e a) lst)
                      a   (+ a l)
                ) ;_  setq
              ) ;_  while
            ) ;_  progn
          ) ;_  if
          (setq p (1+ p))
        ) ;_  if
      ) ;_  repeat
      (entmakex
        (append
          (list
            '(0 . "LWPOLYLINE")
            '(100 . "AcDbEntity")
            '(100 . "AcDbPolyline")
            (cons 90 (length lst))
            (assoc 70 (entget e))
          ) ;_  list
          (mapcar
            (function
              (lambda (x)
                (cons 10 x)
              ) ;_  lambda
            ) ;_  function
            lst
          ) ;_  mapcar
        ) ;_  append
      ) ;_  entmakex
    ) ;_  progn
  ) ;_  if
)

[ilka_t]

посмотрел понравилось, но я думаю что стоит добавит еще 1 команду
или чуть-чуть изменить существующую-

PL-DIV -Разбивает выбранный сегмент полилинии на указанное количество сегментов или через указанное расстояние


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

А програмка супер

молодцы

[VVA]

Добавлена новая команда
PL-DIVALL -Разбивает все сегменты полилинии на указанное количество сегментов или через указанное расстояние

[Inner]

Сообщение от VVA PL-JOIN -Объединение полилиний чохом

Мы на эту команду теперь дружно молимся двумя проектными отделами двух контор. Спасибо огромное. Высочайший респект.

[Nike]

Спасибо за замечательный набор программ!
Может быть уважаемым авторам не составит труда добавить программку, которая бы по одиночному клику на полилинии строила бы фаску и скругление смежных сегментов, ближайших к точке выбора.

[Profan]

Для Nike.
Аналогичная тема:
http://www.autocad.ru/cgi-bin/f1/board.cgi?t=29880Df

[Krieger]

А как сделать реверс дуговых сегментов?
Как ни крути тип линии в одну сторону направлен.
AutoCAD2007
[ATTACH]1158912159.gif[/ATTACH]

[Кулик Алексей aka kpblc]

Это не сделать, наколько я помню, вообще никак. Только если изготовить новый тип линии и его назначать на полилинию

[Sleekka]

Спасибо огромное всем программистам за огромный труд!
2VVA

(полилинии не теряют ассоциативность)

Если вас не затруднит разъясните пожалуйста что здесь имелось ввиду?

[AleX]

Наверно более актуально преобразование SPLINE в 2D_POLYLINE.Как-то начинал, но результата так и нет.

[VVA]

>Krieger №18 Версия Автокада тут ни при чем. Отрисуй две зеркальные дуги и увидишь, что типом линии они покрываются одинаково. Такое ощущение, что при встрече дуги (дугового сегмента) по алгоритму заново рассчитываются начало/конец дуги, причем справа-налево и против часовой. Мы у себя для этих целей имеем типы линий - перевертыши.
>AleXПочему именно в 2D_POLYLINE? Управляющие точки могум иметь различные координаты Z. Тут наверное только 3d polyline.
>Sleekka
Ассоциативновть полилинии, это когда она задает контур каким-либо другим примитивам. Я знаю два: штриховка и видовой экран. Причем ассоциативность штриховки иногда слетает. Т.к. в своей работе часто пользуюсь подрезанными видовыми экранами, то особо хочу подчеркнуть, что если в PL-VxAdd будет указан видовой экран, то он подрежется полилинией. Получается 2 в 1: подрезаем В.Э. и указываем новую конфигурацию, чем я особо доволен.
[ATTACH]1159164515.jpg[/ATTACH]

[AleX]

>VVA
"Почему именно в 2D_POLYLINE? Управляющие точки могум иметь различные координаты Z. Тут наверное только 3d polyline."

По двум причинам:
1. в 2D_POLYLINE конечно же 2-х мерный SPLINE. Задачка уж больно интересная.
Преобразование в 2D_POLYLINE позволяет уменьшить количество точек ее определяющих, что может быть полезным, например при написании управляющих программ станков с ЧПУ. Что-то вроде имеющейся возможности определить элипс участками полилинии.
2. В 3d polyline полилинию через точки наверно банально и просто. Поискав по форумам можно найти почти готовые решения.

[luser]

vva.
спасибо огромное за ваш труд, очень облгечает рутинные операции.
пожелание можна ли дополнить функциями копирования сегментов,
т.е по указанным пользователем сегментам pline создавался новый
объект-копия включающий в себя только указанные сегменты.
еще раз спасибо.

[VVA]

>AleX

Преобразование в 2D_POLYLINE позволяет уменьшить количество точек ее определяющих, что может быть полезным, например при написании управляющих программ станков с ЧПУ

Я не знаю другого математического решения кроме как апроксимация 2d/3d линейными сегментами заданной длины. Даже здесь это делают так (и за деньги).

Что-то вроде имеющейся возможности определить элипс участками полилинии.

А про системную переменную PELLIPSE знаешь?

В 3d polyline полилинию через точки наверно банально и просто

А зачем искать трудности? :wink:
>luser Сейсас готовится обновление с найденными багами KAI, попробую учесть и твое предложение.

[luser]

VVA.
спасибо, ждем новых версий.

[AleX]

А про системную переменную PELLIPSE знаешь?

Обижаешь.

[ilka_t]

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

[VVA]

Выложены новые обновления от 29.09.2006
1. Добавлена новая команда
PL-CLONE - Из указанных пользователем сегментов полилинии создавается новая полилиния
2.В замене линейного сегмента в полилинии дуговым сегментом предусмотрена опция задания радиуса
радиус может быть положительным и отрицательным (влияет на
направление дуги)
3. PL-A2L и PL-L2A подружились с UCS
4. Удаление совпадающих вершин полилинии (PL-VxOpt) работает с группой объектов, а не по одной

[P_S]

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

(defun C:con_ed (/ object object2)
(defun obrabotka ()
(if (> vert_no1 vert_no2)
(while do_next
(if (setq
new_pt (getpoint
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property
vname
'Coordinate
(if (= begin_vert 0)
0
(- begin_vert 1)
)
)
)
)
"\nСледующая вершина"
)
)
(progn
(setq
new_pos (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 1))
(vl-remove (last new_pt) new_pt)
)
)
(vla-put-Coordinate vname begin_vert new_pos)


(if (<= (+ 1 begin_vert) (vlax-curve-getEndParam vname))
(setq begin_vert (+ 1 begin_vert))
(progn (exit)
(princ)
)
)
)
(setq do_next nil)
)
)

(while do_next
(if (setq
new_pt (getpoint
(vlax-safearray->list
(vlax-variant-value
(vlax-get-property
vname
'Coordinate
begin_vert
)
)
)
"\nСледующая вершина"
)
)
(progn
(setq
new_pos (vlax-safearray-fill
(vlax-make-safearray vlax-vbDouble '(0 . 1))
(vl-remove (last new_pt) new_pt)
)
)
(vla-put-Coordinate vname (- begin_vert 1) new_pos)


(if (> begin_vert 1)
(setq begin_vert (- begin_vert 1))
(progn (exit)
(princ)
)
)
)
(setq do_next nil)
)
)
)
(princ)
)
;;Main function;;
(setq object (entsel
"\nЩелкните по той части полилинии, которую собираетесь редактировать"
)
name (car object)
place (cadr object)
prlst (entget name)
)
(if (equal (cdr (assoc 0 prlst)) "LWPOLYLINE")
(progn
(setq
vname (vlax-ename->vla-object (car object))
dist1 (vlax-curve-getDistAtPoint
vname
(vlax-curve-getClosestPointTo
vname
(cadr object)
)
)
object2 (entsel
"\nА теперь щелкните вблизи от той вершины, с которой собираетесь начать"
)
name2 (car object2)
place2 (cadr object2)
vname2 (vlax-ename->vla-object (car object2))
dist2 (vlax-curve-getDistAtPoint
vname2
(vlax-curve-getClosestPointTo
vname2
(cadr object2)
)
)
vert_no1 (vlax-curve-getParamAtDist vname dist1)
vert_no2 (vlax-curve-getParamAtDist vname dist2)
begin_vert (if (< (fix vert_no2) 0.5)
(fix vert_no2)
(+ (fix vert_no2) 1)
)
do_next T
)
(if (eq name name2)
(obrabotka)
(progn
(alert
"Очень странно!\nСначала был указан другой объект.\nНе желаете ли подумать,\nчто же вы хотите делать?"
)
(princ)
)
)
)
(progn
(alert "С выбранным объектом\nв такие игры не играют")
(princ)
)
)
)

[Profan]

А это что такое:

Код:

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

Команда: CON_ED

Щелкните по той части полилинии, которую собираетесь редактировать
А теперь щелкните вблизи от той вершины, с которой собираетесь начать
Следующая вершина
Следующая вершина
Следующая вершина
Следующая вершина
Следующая вершина; ошибка: Возникло исключение: 0xC0000005 (Нарушение доступа)
; предупреждение: раскрутка пропущена для неверное исключение

Команда:

[VVA]

PL-VxMove - программа для редактирования вершин без таскания за ручки. Дополнительные ф-ции по ссылке с поста №1.
Будет включена в новое обновление. Интересуют замечания по интерфейсу.

Код:

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

(defun C:PL-VxMove ( / *error* next ent-pline pl Npt Ovx par vx lst)
(setq *error* pltool-err)
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)) next t)
(setvar "CMDECHO" 0)
(vla-startundomark *kpblc-activedoc*)
(while next
  (if (setq ent-pline (entsel "\nУкажите изменяемую вершину полилинии <выход>: "))
  (if (and (lib:Is-object-modifed (car ent-pline) nil)
        (member (vla-get-ObjectName (setq pl (vlax-ename->vla-object (car ent-pline))))
                '("AcDb2dPolyline" "AcDbPolyline" "AcDb3dPolyline")))
    (progn
      	(setq Npt (osnap (cadr ent-pline) "_nea")
	      Npt (trans Npt 1 0)
	     par (vlax-curve-getParamAtPoint pl Npt)
	     par (fix (+ 0.5 par)) ;_Ближайшая вершина
    	     par (if (and (eq (vla-get-closed pl) :vlax-true)
		    (= par (vlax-curve-getEndParam pl))) 0 par)
	      Ovx (trans (vlax-curve-getPointAtParam pl par) 0 1))
      (initget "X")
      (while (/= "X" (setq Npt (getpoint Ovx (strcat "\nНовое положение вершины " (itoa (1+ par)) "[выход(X)] <оставить>:"))))
	(if Npt (progn
	(setq Npt (trans Npt 1 (car ent-pline))
	      par (if (and (eq (vla-get-closed pl) :vlax-true)
		    (= par (vlax-curve-getEndParam pl))) 0 par)
	      vx (lib:pline-get-verts pl)
	      vx (subst-i par (if (= (vla-get-ObjectName pl) "AcDbPolyline")
				(list (car Npt)(cadr Npt))
				Npt) vx)
	      lst (apply 'append vx))	  
      (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill
	(vlax-make-safearray vlax-vbDouble (cons 0 (1- (length lst)))) lst)))
	))
        (setq par (1+ par))
        (if (> par (vlax-curve-getEndParam pl))(setq par 0))
	(setq par (if (and (eq (vla-get-closed pl) :vlax-true)
		    (= par (vlax-curve-getEndParam pl))) 0 par))
	(setq Ovx (trans (vlax-curve-getPointAtParam pl par) 0 1))
	(initget "X")
	)
      )
    (princ "*** Объект на блокированном слое или не полилиния ***")
    )
    (setq next nil))
);_while
(princ))

Следующая вершина; ошибка: Возникло исключение: 0xC0000005 (Нарушение доступа) ; предупреждение: раскрутка пропущена для неверное исключение

Нельзя в полилинии (LW) обновлять одну вершину. Надо обновлять все координаты.Вот здесь с этим боролись.

[KAI]

По интерфейсу:
не мешало бы добавить опции "вперед" и "назад" (или как в Pedit, Prev/Next), а уж если и Undo на неверно введенную точку!

Кстати, после выхода из программы по Esc надо жать 3 раза на U, чтобы отменить действие команда (при нормальном выходе все OK), далее листинг действий:

Command: PL-VXMOVE

Укажите изменяемую вершину полилинии <выход>:
Новое положение вершины 2[выход(X)] <оставить>:
Новое положение вершины 3[выход(X)] <оставить>:
Новое положение вершины 4[выход(X)] <оставить>:*Cancel*

Команда прервана пользователем
Command: u
PL-VXMOVE
Command: u
GROUP
Command: u
GROUP
Command:

[Игорь Богаченко]

Прекрасный набор команд. Удобно оформлен. Хотя это не ново. В ToolPac это уже есть, да и не мешало бы посмотреть создателю, как реализовано это все в GeoniCS. Намного удобней.
Если возможно, то добавьте, пожалуйста, в функцию "добавления вершин в полилинию" возможность редактирования при включенных ручках, или подсвеченных вершин. А то добавляешь вершину, а рядом уже есть. Приходится корректировать.

[Кулик Алексей aka kpblc]

Насчет Toolpac'a я не знаю, может, он и стал бесплатным, но за GeoniCS (при условии всех его плюсов и минусов) платить приличные суммы лично я не согласный.
И потом, как-то нелогично получается - Toolpac удобнее, Geonics вообще заоблачные высоты, и тут же "добавьте то-то и то-то"...
---
P.S. Обязательно прочтите мою подпись!
---
Добавлено:
В GeoniCS масса вещей (если вообще не все) сделаны на ObjARX, а там ничего не посмотришь, кроме как на междумордие да результаты работы. И потом пытаться сделать на лиспе то же самое. у меня лично подобные трюки прокатывают далеко не всегда

[Игорь Богаченко]

Я совсем не хочу уменьшить значение твоей программы, но, некоторые моменты в Геониксе реализованы гораздо удобней. И если бы была возможность вытащить в Автокад из Геоникса набор команд по редактированию полилинии, то меня бы все устроило. Имелась в виду концепция решения.

[MIP]

>>Игорь Богаченко

Я совсем не хочу уменьшить значение твоей программы, но, некоторые моменты в Геониксе реализованы гораздо удобней. И если бы была возможность вытащить в Автокад из Геоникса набор команд по редактированию полилинии, то меня бы все устроило. Имелась в виду концепция решения.

В GeoniCS многие вещи сделаны удобно, но реализовать некоторые приятные возможности на лисп просто не возмжно, а вот извлечь ARX библиотеки, без помощи разработчика врядли получиться и насколько я его знаю они пока это делать не собираются. Написать аналог можно, но кто этим займеться?
Поэтому пользуемся тем что есть! И низкий поклон VVA за собраную до кучки информацию и всем авторам любезно предоставленных программ.

[VVA]

Новый АВТОНОМНЫЙ вариант PL-VxMove с учетом замечаний KAI и Игорь Богаченко

Код:

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

(defun C:PL-VxMove ( / *error* next ent-pline pl Npt Ovx par vx lst undolst what str pdr nab)
  (defun DTR (a)(* pi (/ a 180.0)))
  (defun _vxgrdraw ( ptdraw color / ang pt11 pt12 pt21 pt22 len )
  (setq len (* 0.03 (getvar "VIEWSIZE"))
       ang 0
       pt11 (polar ptdraw (+ ang (dtr 225)) len)
       pt12 (polar ptdraw (+ ang (dtr 45)) len)
       pt21 (polar ptdraw (+ ang (dtr 315)) len)
       pt22 (polar ptdraw (+ ang (dtr 135)) len))
  (grvecs (list color pt11 pt12 pt21 pt22)))
(defun sbst-i (indel zn sps / buff i e1)
  (setq	i 0 buff nil) ;_ End of setq
  (foreach e1 sps (if (= i indel)
   (setq buff (append buff (list zn)))(setq buff (append buff (list e1))))
    (setq i (1+ i))) buff)
(defun *error* (msg)
  (princ "\nКоманда прервана пользователем")
  (while (> (getvar "CMDACTIVE") 0)(command))  
  (vla-endundomark *kpblc-activedoc*)
  (SSSETFIRST)(vl-cmdf "_.redrawall")(princ))
(defun Is-object-modifed (object param /) 
    (if (= (type object) 'ENAME)(setq object (vlax-ename->vla-object object)))
    (and (or param (setq param '"layer"))
      (vlax-property-available-p object param t)
         (vlax-property-available-p object "layer")
	 (eq (vla-get-Lock (vla-item (vla-get-Layers
	     (vla-get-activedocument(vlax-get-acad-object)))
             (vla-get-Layer object))) :vlax-false)))
(defun group-by-num (lst num / ls ret)
(if (= (rem (length lst) num ) 0)
 (progn (setq ls nil)(repeat (/ (length lst) num)
    (repeat num (setq ls (cons (car lst) ls) lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun pline-get-verts (pline_obj / verts)
      (setq verts (vlax-get pline_obj 'Coordinates)
      verts (cond((wcmatch (vlax-get pline_obj 'Objectname )
           "AcDb2dPolyline,AcDb3dPolyline")(group-by-num verts 3))
        ((eq (vlax-get pline_obj 'Objectname ) "AcDbPolyline")
         (group-by-num verts 2)) (T nil))))
(defun vecs_grdraw ( ptdraw ang color / pt1 pt2 )
  (setq pt1 (polar ptdraw (+ ang (dtr 135)) (* 0.05 (getvar "VIEWSIZE"))))
  (setq pt2 (polar ptdraw (+ ang (dtr 225)) (* 0.05 (getvar "VIEWSIZE"))))
  (grvecs (list color pt1 ptdraw ptdraw pt2)))
(setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)) next t)
(setvar "CMDECHO" 0)(vla-startundomark *kpblc-activedoc*)
(while next (SSSETFIRST)(vl-cmdf "_redrawall")
  (if (setq ent-pline (entsel "\nУкажите изменяемую вершину полилинии <выход>: "))
  (if (and (Is-object-modifed (car ent-pline) nil)
        (member (vla-get-ObjectName (setq pl (vlax-ename->vla-object (car ent-pline))))
                '("AcDb2dPolyline" "AcDbPolyline" "AcDb3dPolyline")))
    (progn (setq nab nil nab (ssadd))(ssadd (car ent-pline) nab)
      (SSSETFIRST nab nab)(setq nab nil)
      (setq Npt (osnap (cadr ent-pline) "_nea"))
      (setq  Npt (trans Npt 1 0)
	     par (vlax-curve-getParamAtPoint pl Npt)
	     pdr (+ 0.5 (fix par))  par (fix (+ 0.5 par)) ;_Ближайшая вершина
    	     par (if (and (eq (vla-get-closed pl) :vlax-true)
		    (= par (vlax-curve-getEndParam pl))) 0 par)
	      Ovx (trans (vlax-curve-getPointAtParam pl par) 0 1)
	      what 1+ str "следующая" undolst nil)
      (vecs_grdraw (setq Npt (trans (vlax-curve-getPointAtParam pl pdr) 0 1))
	 (angle Npt (trans (vlax-curve-getPointAtParam pl
	     (+ (vlax-curve-getParamAtPoint pl (trans Npt 1 (car ent-pline))) 1e-5))
	     (car ent-pline) 1)) 1)
      (_vxgrdraw Ovx -1)(initget "X N P U _X N P U")
      (while (/= "X" (setq Npt (getpoint Ovx
				(strcat "\nНовое положение вершины " (itoa (1+ (fix par)))
				        " [следующий(N)/предыдущий(P)/отмени(U)/выход(X)] <" str ">:"))))
	(cond
	  ((null Npt) nil)
	  ((= Npt "N")(setq what 1+ str "следующая"))
	  ((= Npt "P")(setq what 1- str "предыдущая"))
	  ((listp Npt)
	   (setq Npt (trans Npt 1 (car ent-pline))
	         par (if (and (eq (vla-get-closed pl) :vlax-true)
	               (= par (vlax-curve-getEndParam pl))) 0 par)
	      vx (pline-get-verts pl)
	 undolst (append (list(list par (apply 'append vx))) undolst)
	      vx (sbst-i par (if (= (vla-get-ObjectName pl) "AcDbPolyline")
		 (list (car Npt)(cadr Npt)) Npt) vx) lst (apply 'append vx))
	   (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill
             (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length lst)))) lst)))
	   (vl-cmdf "_redrawall")
	   (vecs_grdraw (setq Npt (trans (vlax-curve-getPointAtParam pl pdr) 0 1))
		(angle Npt (trans (vlax-curve-getPointAtParam pl
	           (+ (vlax-curve-getParamAtPoint pl (trans Npt 1 (car ent-pline))) 1e-5))
		(car ent-pline) 1)) 1))
	   ((= Npt "U")
	    (setq lst (car undolst) undolst (cdr undolst))
	    (if lst (progn
	      (setq par (car lst) lst (cadr lst))
	      (vla-put-coordinates pl (vlax-make-variant (vlax-safearray-fill
                (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length lst)))) lst)))
		(setq Ovx (trans (vlax-curve-getPointAtParam pl par) 0 1))
		(vl-cmdf "_redrawall")
	      (vecs_grdraw (setq Npt (trans (vlax-curve-getPointAtParam pl pdr) 0 1))
		(angle Npt (trans (vlax-curve-getPointAtParam pl
	           (+ (vlax-curve-getParamAtPoint pl (trans Npt 1 (car ent-pline))) 1e-5))
		(car ent-pline) 1)) 1))
	      (alert "Нечего отменять"))) (t nil))
	(_vxgrdraw Ovx 0)(if (/= Npt "U")(setq par (what par)))
        (if (> par (vlax-curve-getEndParam pl))(setq par 0))
        (if (< par 0)(setq par (if (eq (vla-get-closed pl) :vlax-true)
            (1- (vlax-curve-getEndParam pl))(vlax-curve-getEndParam pl))))
	(setq par (if (and (eq (vla-get-closed pl) :vlax-true)
		    (= par (vlax-curve-getEndParam pl))) 0 par))
	(setq Ovx (trans (vlax-curve-getPointAtParam pl par) 0 1))
	(_vxgrdraw Ovx -1)(initget "X N P U _X N P U")))
    (princ "*** Объект на блокированном слое или не полилиния ***"))
    (setq next nil)));_while
(vl-cmdf "_redrawall")(vla-endundomark *kpblc-activedoc*)(princ))

При выборе полилинии она подсвечивается ручками и рисуется стрелка по направлению обхода. Возможность редактирования при включенных ручках - мне нравится. Будет включена во все команды по аналогу этой, то же и с undo.

Добавлено
Команда сделана автономной

[P_S]

VVA

Интересуют замечания по интерфейсу

.

Какие были мысли относительно этой команды: указывается направление редактирования, и резиновая нить цепляется за предыдущую вершину, обозначая положение линейного сегмента полилинии после изменения положения вершины. Таким образом, для пользователя процесс схож с вычерчиванием заново участка полилинии.

[VVA]

>P_Sуказывается направление редактирования - пробуй послений вариант

резиновая нить цепляется за предыдущую вершину

- не введет ли это пользователя в заблуждение.

[Игорь Богаченко]

Вроде бы все хорошо, но простите за назойливость, мне не нужно каждую вершину редактировать, а, переходя по полилинии корректировать некоторые из них, не выходя из команды.

[Игорь Богаченко]

Не досмотрел. Так устроит. Большое спасибо.

[Profan]

Объясните, пожалуйста, а чем ручки-то плохи? Выделил полилинию и выбирай любую ручку, если нет ножки.

[Игорь Богаченко]

Этот код не вставляет вершину, а смещает. Это не подходит.
Если применять резинувую нить, то для двух смежных вершин, а не для одной с направлением. И, желательна свобода перемещения по редактируемой полилинии, а не быть привязаным к определенному участку, и двигаться по линии к следующему участку редактирования.
Лучше просто подсветить редактируемую линию, и вставлять вершины в нужных местах.

[Profan]

Для VVA.
А это почему?

Код:

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

Команда: PL-VXMOVE

Укажите изменяемую вершину полилинии <выход>: ; ошибка: no function definition: 
LIB:IS-OBJECT-MODIFED

Команда:

Программа не может работать автономно?

[VVA]

>Игорь Богаченко В № 38 писал

Возможность редактирования при включенных ручках - мне нравится. Будет включена во все команды по аналогу этой, то же и с undo.

PL-VxAdd с ручками уже готова, допишу отмену и выложу обновления. На этой (PL-VxMove) команде можно посмотреть как будет. Чуточку терпения.

Если применять резинувую нить, то для двух смежных вершин, а не для одной с направлением

В лиспе такое нельзя, по крайней мере я не знаю как.
Я тоже сомневаюсь в практической ценности PL-VxMove и согласен с Profan №43 Хотел написать на Profan №45

в №32 писал, здесь забыл Дополнительные ф-ции по ссылке с поста №1.

Но подправлю VVA №38, сделаю ф-цию автономной.

[Profan]

Еще про ручки (такие, знаете ли, миленькие нежные ручки).
Подумавши, свою фразу построил бы по другому:
Выделил полилинию и выбирай любую ручку, если нет ножки, или выбирай с Shift'ом несколько ручек, если тебя привлекает групповуха. :twisted:

[Neznayka]

Спасибо за прогу, но почему не добавляется вершина в полилинии с глобальной шириной, пишет ничего типа не выбранно, очень редко проскакивает. и в 2007 не пашет эта команда, чего-тот не хватает

[VVA]

Пользуясь случаем обновил программы. Исправленные ошибки:
- PL-CLONE, PL-VxRdc Неточночть работы в UCS
- Добавлена команда PL-VX1 - Изменение начала полилинии
- В команду PL-VxMove добавлена опция:
Для 3d полилиний добавляется запрос сохранения Z узла полилинии
- CVPOLY переведена в режим командной строки.
- Вместо нее добавлена PL-3d2d (проецирование 3d на текущую ПСК)
- Entrevs - для замкнутых полилиний вершина остается на месте
- Корректная обработка кривизны и ширины замыкающего сенмента полилинии в ENTREVS
Особо хочу поблагодарить KAI за дельные замечания и советы.

> Neznayka Все добавляется. Просто размер прицела выбора (PICKBOX) должен быть больше текущей толщины полилинии на экране.
Варианта 2:
1. Либо зумом отъедь от полилинии
2. Либо в командной строке PICKBOX и увеличь значение.

Только что проверил: работает в 2007 RUS. Там чистый Лисп. От версии не должно зависеть.

[Neznayka]

> Neznayka Все добавляется. Просто размер прицела выбора (PICKBOX) должен быть больше текущей толщины полилинии на экране.
Варианта 2:
1. Либо зумом отъедь от полилинии
2. Либо в командной строке PICKBOX и увеличь значение.

Только что проверил: работает в 2007 RUS. Там чистый Лисп. От версии не должно зависеть.[/quote]

Все понял , спасибо, поставил новую версию и в 2007 заработало почему-то :roll:

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

вот только акад при разбивки секунд на 15 призадумывается, и это при том , что комп далеко не слабый у меня
[ATTACH]1164096458.GIF[/ATTACH]


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

[VVA]

>Neznayka Тебе поможет эта команда. Несмотря на то, что речь идет о шпалах, можешь рисовать и заборы

Код:

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

(Defun C:RW ( /  ang col dH DL DLN e1 H_put i nev Param pt0 pt11 pt21
		S_spal Vobj *error* adoc Flg CL)
(defun *error* (msg)(vla-endundomark adoc)(setq PICK1 nil)(setvar "CLAYER" CL))
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark adoc)
;;;H_put - ширина пути
;;;S_spal - шаг шпал
;;;DL- на сколько шпалы выступают за путь с одной стороны
  (setq	H_put 3 ;_ширина пути 3 мм
	S_spal 6 ;_шаг шпал 6 мм
	DL 0.5  ;выступают на 0.05 мм
  ) ;_ End of setq
  (setq Flg t)
  (while Flg
    (initget "S")
    (setq e1 (entsel "\nВыберите ось путей [настройки S] <выход>: "))
    (cond
      ((= e1 "S")
       (princ "\nШирина пути в мм <")(princ H_put)(princ "> : ")
       (initget 6)(setq pt0 (getdist))
       (if pt0 (setq H_put pt0)) ;_ End of if
       (princ "\nШаг шпал в мм <")(princ S_spal)(princ "> : ")
       (initget 6)(setq pt0 (getdist))
       (if pt0 (setq S_spal pt0)) ;_ End of if
       (princ "\nВыступ шпал в мм <")(princ DL)(princ "> : ")
       (initget 5)(setq pt0 (getdist))
       (if pt0 (setq DL pt0)) ;_ End of if
      )
      ((null e1)(if (= (getvar "ERRNO") 52)(setq Flg nil e1 nil vobj nil)(princ " *мимо*")))
      (t
       (setq e1 (car e1) vobj (vlax-ename->vla-object e1))
       (cond
	 ((null(vlax-write-enabled-p vobj))(alert "На блокированном слое!"))
	 ((wcmatch (cdr(assoc 0 (entget e1))) "LINE,ARC,SPLINE,*POLYLINE,ELLIPSE,CIRCLE")(setq Flg nil))
	 (t (alert (strcat "Объект " (cdr(assoc 0 (entget e1)))
	    " не может быть осью пути\nОсь пути - полилиния, линия, дуга, сплайн, эллиптическая дуга, круг"))))))
  ) ;_while 
(if vobj (progn
  (setq dH (+ (* H_put 0.5) DL)  
       DLN (vlax-curve-getDistAtParam vobj (vlax-curve-getEndParam vobj))
        col (fix (/ dln s_spal 1.0))
        nev (- DLN (* col S_spal))
        nev (* nev 0.5))
  (setq	PICK1 nil PICK1 (ssadd)) ;_ end of setq
  (setq CL (getvar "CLAYER"))(setvar "CLAYER" (vla-get-Layer vobj))
  (setq i '-1)
  (repeat (+ col 1)
    (setq i (1+ i))
    (setq pt0 (vlax-curve-getPointAtDist vobj (+ (* S_spal i) nev)))
    (setq param (vlax-curve-getParamAtPoint vobj pt0))
    (setq ang (vlax-curve-getFirstDeriv vobj param))
    (setq pt11 (mapcar '+ pt0 ang))
    (setq ang (angle pt0 pt11))
    (setq ang (- ang (* PI 0.5)))
    (setq pt11 (polar pt0 ang dH))
    (setq pt21 (polar pt0 (+ ang PI) dH))
    (vla-AddLine (vla-ObjectIDToObject adoc (vla-get-OwnerID vobj))
      (vlax-3d-point pt11)(vlax-3d-point pt21))
    (ssadd (entlast) PICK1)
  ) ;_ End of repeat
  (vla-Offset vobj (* H_put 0.5))(ssadd (entlast) PICK1)(vla-Offset vobj (- 0 (* H_put 0.5)))(ssadd (entlast) PICK1)
  (setq pt0 (mapcar '(lambda (x)(vlax-get-property vobj x)) '(Linetype LineWeight Color Layer)))
  (setq pt11 (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex PICK1)))))
  (mapcar '(lambda (vla)
	     (mapcar '(lambda (x y)(vlax-put-property vla x y))
		'(Linetype LineWeight Color Layer) pt0)) pt11)
  (setvar "CLAYER" CL)(command "_.-group" "_C" "*" "Трамвайные (ж.д.) пути" PICK1 "")
  (initget "Yes No")(if (= (getkword "\nУдалять ось путей? [Yes/No] <No> : ") "Yes")(vla-erase vobj))
    )
  )
(setq PICK1 nil)
(vla-endundomark adoc)
 (princ)
)

[Neznayka]

интересно я это попробую , но для жд дороги , а заборы все-таки легче выше описанным, имхо

[ShaggyDoc]

Совет программистам:

Для того, чтобы предотвратить ситуацию с неправильным указанием широкой (c физической шириной) полилинии, надо в функцию выбора примитива включать наподобие

Код:

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

 (setq om           (getvar "OSMODE")
          old_aperture (getvar "aperture")
 ) ;_ end of setq
 (setvar "OSMODE" 512)
 (setvar "aperture" (getvar "pickbox"))

;;..... здесь указание на примитив с обработкой правильности
(if (setq ent_selected
        (ru-get-entsel-by-type
                     msg
                     "Примитив недопустимого типа"
                     (list "LINE" "LWPOLYLINE")
                     t
                 ) 

        ) 
        (setq result (list (car ent_selected)
               (trans (osnap (trans (cadr ent_selected) 0 1) "_nea" 1 0)
                     ) 
        ) 
    )

;; Потом восстановление
(setvar "OSMODE" om)
(setvar "aperture" old_aperture)

Функция ru-get-entsel-by-type проверяет тип примитива, блокированность слоя и т.п. Не в ней дело (она вернет список как entsel), а в применении объектной привязки к полученной точке - функция osnap.

[VVA]

>ShaggyDoc Спасибо, использовал.
>Neznayka

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

Пробуй

Код:

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

;;;Команда выравнивает внутренние углы полилинии до 90 градусов
;;;За основу берется самая длинная сторона
;;;
(Defun C:p90 ( / Flg e1 vobj i ang *error* crs pt0 pt1 pt2 pt3 var adoc)
(defun *error* (msg)(vla-endundomark adoc))
(defun pline-get-verts (pline_obj / verts)(setq verts (vlax-get pline_obj 'Coordinates)
      verts (cond ((wcmatch (vlax-get pline_obj 'Objectname ) "AcDb2dPolyline,AcDb3dPolyline")
             (group-by-num verts 3))
             ((eq (vlax-get pline_obj 'Objectname )"AcDbPolyline")(group-by-num verts 2))(T nil))))
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn
(setq ls nil)(repeat (/ (length lst) num)(repeat num (setq ls (cons (car lst) ls) lst (cdr lst)))
(setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object)))(vla-startundomark adoc)
(setq Flg t)(while Flg (setq e1 (entsel "\nВыберите полилинию  <выход>: "))
    (cond ((null e1)(if (= (getvar "ERRNO") 52)(setq Flg nil e1 nil vobj nil)(princ " *мимо*")))
      (t (setq e1 (car e1) vobj (vlax-ename->vla-object e1))
       (cond ((null(vlax-write-enabled-p vobj))(alert "На блокированном слое!"))
	 ((wcmatch (cdr(assoc 0 (entget e1))) "*POLYLINE")(setq Flg nil))
	 (t (alert (strcat "Объект не полилиния"))))))) ;_while 
(if vobj (progn (setq crs (pline-get-verts vobj))(if (> (length crs) 2)(progn
(setq Pt1 nil pt2 nil ptS nil ptE nil var nil)(setq pt1 (car crs))
(mapcar'(lambda ( x )(if (or (null var)(< var (distance pt1 x)))
	   (setq var (distance pt1 x) ptS pt1 ptE x))(setq pt1 x))
 (cdr crs))(setq var nil i 0 lst crs)
(while i
  (if (and (equal (nth i crs) ptS 1e-6)(equal (nth (1+ i) crs) ptE 1e-6))
    (setq i nil)(setq var (append var (list (nth i crs))) i (1+ i) lst (cdr lst))))
(setq crs (append lst var))(setq ang (angle (car crs)(cadr crs)))
(setq lst (list (car crs)(cadr crs)) crs (cddr crs))
(foreach pt crs
  (setq pt1 (last lst)) (setq pt2 (polar pt ang 100))
  (setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100))(setq pt0 (inters pt pt2 pt1 pt3 nil))
  (setq lst (append lst (list pt0)))(setq ang (angle pt1 pt0)))
(setq crs (reverse lst))(setq ang (angle (car lst)(cadr lst)))
(if (or (equal (angle (car crs)(cadr crs)) ang 1e-6)
	(equal (angle (car crs)(cadr crs))(+ ang PI) 1e-6)
	(equal (angle (car crs)(cadr crs))(- ang PI) 1e-6))
  (progn (setq pt1 (car lst))(setq pt0 (car crs))
    (setq pt2 (polar pt0 ang 100))(setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100))
    (setq pt0 (inters pt0 pt2 pt1 pt3 nil))(setq lst (append (reverse(cdr crs))(list pt0)))
    (vla-put-Closed vobj :vlax-true))
  (progn (setq pt1 (car crs))(setq pt2 (cadr crs))
    (setq pt0 (inters (car lst)(cadr lst) pt1 pt2 nil))
    (if (and pt0 (equal (angle pt2 pt1)(angle pt2 pt0) 1e-6))
      (progn (setq pt1 (polar (car lst)(+ ang (* 0.5 PI)) 100))
	(setq pt0 (inters pt2 (polar pt2 ang 100)(car lst) pt1 nil))
	(setq crs (cddr crs))(setq crs (append (list pt0) crs))
	(setq lst (reverse crs))(vla-put-Closed vobj :vlax-true)))))
 (if (= (vla-get-ObjectName vobj) "AcDbPolyline")(setq lst (mapcar '(lambda (cr)(mapcar '+ cr '(0 0))) lst)))
  (setq crs (apply 'append lst))
  (setq var (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray
             vlax-vbDouble (cons 0 (1- (length crs)))) crs)))
(vla-put-Coordinates vobj var)))));_vobj
(vla-endundomark adoc)(princ))
(princ "\nНаберите в командной строке p90")

[Lizzy]

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

В одном файле после использования команды flatten objekts изменилось отбражение вновь проводимых полилиний. Толщина их стало отбражаться в абсолютных величинах, а не относительно экрана. мне удалось только выяснить, что это зависит от величин global width. Где можно это значение "обнулить"? Пока приходится делать это вручную в свойствах... :?:

[Neznayka]

Вы кудесник, это так "окрасивит" мои чертежи,!!! прям сказка,

немогли бы вы на словах рассазать про алгоритм работы, это сравни уравновешивания теодолитного хода?
если Вас интересуют пожелания, то они такие:
некорректно работает с не замкнутой плинией (появляется короткий апендикс который совсем в другую сторону смотрит), и если можно ограничить выпрямляймые углы , скажем от 85 до 95 градусов, а то в зданиях бывают не только прямые углы, и еще чтоб скапом можно было контура обрабатывать, а не по одному.

ОГРОМНОЕ СПАСИБО

[VVA]

>Lizzy Вручную в свойствах, только для всех полилиний сразу.
Выдели объекты, в окне свойств (там где Все) раскрой список, выбери полилинии. в поле Глобальная ширина вбей 0.
>Neznayka Пробуй. Про алгоритм чуть позже

Код:

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

;;;Команда выравнивает внутренние углы полилинии до 90+- допуск градусов
;;;За основу берется самая длинная сторона
;;;
(Defun C:p90 ( / Flg e1 i ang *error* crs pt0 pt1 pt2 pt3 var adoc dop1 dop2)
(defun *error* (msg)(princ msg)(vla-endundomark adoc))
(defun angw1w2 (Wekt1 Wekt2 $P000 / CosA)
(setq Wekt1 (mapcar '- Wekt1 $P000) Wekt2 (mapcar '- Wekt2 $P000) $P000 (mapcar '- $P000 $P000))
 (if (equal (setq CosA (/ (apply '+ (mapcar '* Wekt1 Wekt2))
  (distance $P000 Wekt1) (distance $P000 Wekt2))) -1.0 1e-6) Pi
  (if (equal CosA 0.0 1e-6) Pi2 (atan (sqrt (- 1 (* CosA CosA))) CosA))))
(defun pline-get-verts (pline_obj / verts)(setq verts (vlax-get pline_obj 'Coordinates)
      verts (cond ((wcmatch (vlax-get pline_obj 'Objectname ) "AcDb2dPolyline,AcDb3dPolyline")
             (group-by-num verts 3))
             ((eq (vlax-get pline_obj 'Objectname )"AcDbPolyline")(group-by-num verts 2))(T nil))))
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn
(setq ls nil)(repeat (/ (length lst) num)(repeat num (setq ls (cons (car lst) ls) lst (cdr lst)))
(setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object)))(vla-startundomark adoc)
(setq ang (getangle "\nДопуск в градусах для выравнивания до 90 <любой угол>: "))
(if ang (setq dop1 (- (* 0.5 PI) ang) dop2  (+ (* 0.5 PI) ang))
(setq dop1 nil dop2 nil))
(princ "\nВыберите полилинии ")(setq selset (ssget "_:L" '((0 . "*POLYLINE"))))
(if selset (progn (setq selset (mapcar 'vlax-ename->vla-object  (vl-remove-if 'listp
 (mapcar 'cadr (ssnamex selset)))))
 (mapcar '(lambda(vobj / ug ptS ptE)(setq crs (pline-get-verts vobj))
    (if	(> (length crs) 2)(progn (setq Pt1 nil pt2 nil ptS nil ptE nil var nil)
	(setq pt1 (car crs))(mapcar '(lambda (x)(if (or (null var) (< var (distance pt1 x)))
        (setq var (distance pt1 x) ptS pt1 ptE x))  (setq pt1 x))(cdr crs))(setq i 0 var 0)
	(while (and i (nth i crs))(if (and (equal (nth i crs) ptS 1e-6)
               (equal (nth (1+ i) crs) ptE 1e-6))(setq var (1+ i) i (+ (length crs) 1)))
	    (setq i (1+ i)))
	(if (> var (* 0.5 (length crs)))(setq crs (reverse crs) i ptS ptS ptE ptE i))
	(setq var nil i 0 lst crs)
	(while (and i (nth i crs))
	  (if (and (equal (nth i crs) ptS 1e-6)(equal (nth (1+ i) crs) ptE 1e-6))
	    (setq i nil)(setq var (append var (list (nth i crs)))
		  i   (1+ i) lst (cdr lst))))
	(setq crs (append lst var))(setq ang (angle (car crs) (cadr crs)))
	(setq lst (list (car crs) (cadr crs)) crs (cddr crs))
	(foreach pt crs (setq pt1 (last lst))
	  (setq pt2 (polar pt ang 100))(setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100))
	  (setq ug (angw1w2 pt (cadr (reverse lst)) pt1))
	  (if (or (null dop1)(and (> ug dop1)(< ug dop2)))
	    (setq pt0 (inters pt pt2 pt1 pt3 nil))(setq pt0 pt))
	  (setq lst (append lst (list pt0)))(setq ang (angle pt1 pt0)))
	(setq crs (reverse lst))(setq ang (angle (car lst) (cadr lst)))
	(if (or	(equal (angle (car crs) (cadr crs)) ang 1e-6)
		(equal (angle (car crs) (cadr crs)) (+ ang PI) 1e-6)
		(equal (angle (car crs) (cadr crs)) (- ang PI) 1e-6))
	  (progn (setq pt1 (car lst))(setq pt0 (car crs))(setq pt2 (polar pt0 ang 100))
		 (setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100))(setq pt0 (inters pt0 pt2 pt1 pt3 nil))
		 (setq lst (append (reverse (cdr crs)) (list pt0)))
		 (vla-put-Closed vobj :vlax-true))
	  (progn (setq pt1 (car crs))(setq pt2 (cadr crs))
	    (setq pt0 (inters (car lst) (cadr lst) pt1 pt2 nil))
	    (if	(and pt0 (equal (angle pt2 pt1) (angle pt2 pt0) 1e-6))
	      (progn (setq pt1 (polar (car lst) (+ ang (* 0.5 PI)) 100))
		     (setq pt0 (inters pt2 (polar pt2 ang 100) (car lst) pt1 nil))
		     (setq crs (cddr crs))(setq crs (append (list pt0) crs))
		     (setq lst (reverse crs))(vla-put-Closed vobj :vlax-true)))))
	(if (= (vla-get-ObjectName vobj) "AcDbPolyline")
	  (setq lst (mapcar '(lambda (cr) (mapcar '+ cr '(0 0))) lst)))
	(setq crs (apply 'append lst))(setq var (vlax-make-variant (vlax-safearray-fill
        (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length crs)))) crs)))
	(vla-put-Coordinates vobj var)))) selset))) ;_selset
(vla-endundomark adoc)(princ))(princ "\nНаберите в командной строке p90")

Если в ответ на запрос

Допуск в градусах для выравнивания до 90 <любой угол>:

ввести 5, то будут обрабатываться углы 85-95 градусов

[Кочетков Андрей]

Комментарий к программе PL-VxRdc (прополка полилинии):

работаю с lwpolyline
она имеет свойство Замкнута

программа выдает ошибку

Код:

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

Command: PL-VxRdc
25 found

Command:
Введите max отклонение от прямой (H) [угловой допуск A/отклонение H] <0.15>:
ERRNO # 0: Automation Error. Invalid index

Command: *Cancel*

Снимаю атрибут Замкнута.
Программа работает корректно.

[VVA]

Спасибо проверю

[VVA]

>Кочетков Андрей Исправил. Выложил в download

[Кочетков Андрей]

Спасибо

[Neznayka]

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

[VVA]

Код:

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

;;;Команда выравнивает внутренние углы полилинии до 90+- допуск градусов 
;;;За основу берется самая длинная сторона 
;;;http://forum.dwg.ru/showthread.php?p=104952#post104952
(Defun C:p90 ( / Flg e1 i ang *error* crs pt0 pt1 pt2 pt3 var adoc dop1 dop2) 
(defun *error* (msg)(princ msg)(vla-endundomark adoc)) 
(defun angw1w2 (Wekt1 Wekt2 $P000 / CosA) 
(setq Wekt1 (mapcar '- Wekt1 $P000) Wekt2 (mapcar '- Wekt2 $P000) $P000 (mapcar '- $P000 $P000)) 
 (if (equal (setq CosA (/ (apply '+ (mapcar '* Wekt1 Wekt2)) 
  (distance $P000 Wekt1) (distance $P000 Wekt2))) -1.0 1e-6) Pi 
  (if (equal CosA 0.0 1e-6) Pi2 (atan (sqrt (- 1 (* CosA CosA))) CosA)))) 
(defun pline-get-verts (pline_obj / verts)(setq verts (vlax-get pline_obj 'Coordinates) 
      verts (cond ((wcmatch (vlax-get pline_obj 'Objectname ) "AcDb2dPolyline,AcDb3dPolyline") 
             (group-by-num verts 3)) 
             ((eq (vlax-get pline_obj 'Objectname )"AcDbPolyline")(group-by-num verts 2))(T nil)))) 
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn 
(setq ls nil)(repeat (/ (length lst) num)(repeat num (setq ls (cons (car lst) ls) lst (cdr lst))) 
(setq ret (append ret (list (reverse ls))) ls nil)))) ret) 
(vl-load-com)(setq adoc (vla-get-activedocument (vlax-get-acad-object)))(vla-startundomark adoc)
(setq ang *P90-ANG*)(princ"\nДопуск в градусах для выравнивания до 90 [Любой] <")(initget "Любой Any _Any Any")
(princ (if ang (/ (* ang 180.0) pi) "любой угол"))(princ">: ")(setq ang (getangle))
(if (= ang "Any")(setq ang nil *P90-ANG* nil))(if ang (setq *P90-ANG* ang))
(if ang (setq dop1 (- (* 0.5 PI) ang) dop2  (+ (* 0.5 PI) ang)) 
(setq dop1 nil dop2 nil))(VL-PROPAGATE '*P90-ANG*) 
(princ "\nВыберите полилинии ")(setq selset (ssget "_:L" '((0 . "*POLYLINE")))) 
(if selset (progn (setq selset (mapcar 'vlax-ename->vla-object  (vl-remove-if 'listp 
 (mapcar 'cadr (ssnamex selset))))) 
 (mapcar '(lambda(vobj / ug ptS ptE)(setq crs (pline-get-verts vobj)) 
    (if   (> (length crs) 2)(progn (setq Pt1 nil pt2 nil ptS nil ptE nil var nil) 
   (setq pt1 (car crs))(mapcar '(lambda (x)(if (or (null var) (< var (distance pt1 x))) 
        (setq var (distance pt1 x) ptS pt1 ptE x))  (setq pt1 x))(cdr crs))(setq i 0 var 0) 
   (while (and i (nth i crs))(if (and (equal (nth i crs) ptS 1e-6) 
               (equal (nth (1+ i) crs) ptE 1e-6))(setq var (1+ i) i (+ (length crs) 1))) 
       (setq i (1+ i))) 
   (if (> var (* 0.5 (length crs)))(setq crs (reverse crs) i ptS ptS ptE ptE i)) 
   (setq var nil i 0 lst crs) 
   (while (and i (nth i crs)) 
     (if (and (equal (nth i crs) ptS 1e-6)(equal (nth (1+ i) crs) ptE 1e-6)) 
       (setq i nil)(setq var (append var (list (nth i crs))) 
        i   (1+ i) lst (cdr lst)))) 
   (setq crs (append lst var))(setq ang (angle (car crs) (cadr crs))) 
   (setq lst (list (car crs) (cadr crs)) crs (cddr crs)) 
   (foreach pt crs (setq pt1 (last lst)) 
     (setq pt2 (polar pt ang 100))(setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100)) 
     (setq ug (angw1w2 pt (cadr (reverse lst)) pt1)) 
     (if (or (null dop1)(and (> ug dop1)(< ug dop2))) 
       (setq pt0 (inters pt pt2 pt1 pt3 nil))(setq pt0 pt)) 
     (setq lst (append lst (list pt0)))(setq ang (angle pt1 pt0))) 
   (setq crs (reverse lst))(setq ang (angle (car lst) (cadr lst))) 
   (if (or   (equal (angle (car crs) (cadr crs)) ang 1e-6) 
      (equal (angle (car crs) (cadr crs)) (+ ang PI) 1e-6) 
      (equal (angle (car crs) (cadr crs)) (- ang PI) 1e-6)) 
     (progn (setq pt1 (car lst))(setq pt0 (car crs))(setq pt2 (polar pt0 ang 100)) 
       (setq pt3 (polar pt1 (+ ang (* 0.5 PI)) 100))(setq pt0 (inters pt0 pt2 pt1 pt3 nil)) 
       (setq lst (append (reverse (cdr crs)) (list pt0))) 
       (vla-put-Closed vobj :vlax-true)) 
     (progn (setq pt1 (car crs))(setq pt2 (cadr crs)) 
       (setq pt0 (inters (car lst) (cadr lst) pt1 pt2 nil)) 
       (if   (and pt0 (equal (angle pt2 pt1) (angle pt2 pt0) 1e-6)) 
         (progn (setq pt1 (polar (car lst) (+ ang (* 0.5 PI)) 100)) 
           (setq pt0 (inters pt2 (polar pt2 ang 100) (car lst) pt1 nil)) 
           (setq crs (cddr crs))(setq crs (append (list pt0) crs)) 
           (setq lst (reverse crs))(vla-put-Closed vobj :vlax-true))))) 
   (if (= (vla-get-ObjectName vobj) "AcDbPolyline") 
     (setq lst (mapcar '(lambda (cr) (mapcar '+ cr '(0 0))) lst))) 
   (setq crs (apply 'append lst))(setq var (vlax-make-variant (vlax-safearray-fill 
        (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length crs)))) crs))) 
   (vla-put-Coordinates vobj var)))) selset))) ;_selset 
(vla-endundomark adoc)(princ))(princ "\nНаберите в командной строке p90")

Значение сохраняется в текущем сеансе редактирования

[Profan]

Выражаю особую благодарность VVA за программу "Прополка полиинии". Очень пригодилась для значительного уменьшения количества вершин полилиний после выполнения таких преобразований: CDR->DWG->WMF->DWG.

[Profan]

Для VVA.
В вашей функции PL-L2A есть запрос:

Код:

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

Выберите нужный дуговой сегмент в полилинии [отмени U/радиус R/выход X] <выход>:

Наверное, надо слово "дуговой" заменить на "линейный"?

[VVA]

>Profan Спасибо, Владимир. Как-то пропустил твой пост, только сейчас заметил. Заменил. Исправления от 14.03.2007
Помимо этого добавлено:
ConvTo2d -Преобразование линейных объектов в 2D полилинии
ConvTo3d -Преобразование линейных объектов в 3D полилинии
MPL -Построение средней линии
R3P -Прямоугольгик по 3-м точкам
PL-JOIN -Объединение полилиний чохом (если есть 3d полилинии, то объединяет и их тоже, но не с 2d, а между собой)
PL-JOIN3D -Объединение 3D полилиний (Отрезки + 3d полилинии)
Исправлены мелкие и не очень (спасибо KAI) глюки.

[KAI]

Исправлены мелкие и не очень (спасибо KAI) глюки.

Правда еще более маленькие появились, но это мелочи.
Даже мне, зунуде, кажется, что уже все в норме. Есть конечно мелкие огрехи, кое в чем с автором я не согласен, но на то и АВТОР! Ему видней.
А в целом комплекс ОЧЕНЬ хороший! Рекомендую!
Огромное спасибо VVA!

[Profan]

Для VVA.
Вот ЗДЕСЬ есть еще программа Евгения Елпанова "Изменение начальной и конечной ширины произвольного сегмента полилинии". Вы не хотите включить ее или ваш аналог в пакет PLTOOLS?
Правильно вы сделали, что сгруппировали кнопки.

[VVA]

Поступают просьбы добавить команду, чтоб выбирать надо было бы только один объект, а команда объединяла все примыкающие объекты (линии, полилинии, дуги...) в полилинию.
Выкладываю на тестирование и для предложений/замечаний.
Алгорити взят у ChainSelect Fatty

Код:

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

;;* Утилита объединения набора линий в полилинию*
;;------------------------------------------------
;;Алгорити взят у ChainSelect Fatty
;;http://www.cadforyou.spb.ru/index.php?current_section=section_programs_page
;;Доработан до понимания ARC,PLINE,LINE
;;Для выполнения необходимо указать только точку
;; pt - точка в мировой системе координат !!!
;;    - или имя (ENAME VLA-OBJECT) начального примитива
;; fuzz - точность
;;Возвращает список vla объектов
(defun ChainSelectFromAny ( pt fuzz / chain_list couple ept line_list ln loop pda spt ss ln1 cycl)
(vl-load-com)
(cond ((= (type pt) 'ENAME)
       (setq ln (vlax-ename->vla-object pt)
             pt nil
             )
       )
      ((= (type pt) 'VLA-OBJECT)(setq ln pt pt nil))
      (t nil))
(if (setq ss (ssget "_I")
          ss nil
          ss (ssget "_X" '((0 . "ARC,LINE,*POLYLINE")))
    ) ;_ end of setq
  (progn
    (if pt
      (progn
        (setq ln1 (vla-addLine
                    (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
                             (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object))))
                             ) ;_ end of and
                      (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
                      (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
               (vlax-3d-point pt)
               (vlax-3d-point (mapcar '- pt '(1 1 0)))))
        (setq ln ln1)))
     (setq spt (vlax-curve-getStartPoint ln)
           ept (vlax-curve-getEndPoint ln))
    (setq line_list  (mapcar 'vlax-ename->vla-object
                             (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                     ) ;_ end of mapcar
          chain_list nil
          chain_list (cons ln chain_list)
    ) ;_ end of setq
    (setq line_list (vl-remove-if
                      '(lambda (x)
                         (eq "AcDb3dPolyline" (vla-get-objectname x))
                       ) ;_ end of lambda
                      line_list
                    ) ;_ end of vl-remove-if
    ) ;_ end of setq
    (setq loop t cycl 0)
    (while loop
     (while
        (setq couple
               (vl-remove-if-not
                 (function (lambda (x)
                             ;; значение допуска 0.01 можно изменить по ситуации
                             ;; в зависимости от единиц черчения : 
                             (or (equal (vlax-curve-getStartPoint x)
                                        (vlax-curve-getStartPoint ln)
                                        fuzz      ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getStartPoint x)
                                        (vlax-curve-getEndPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        (vlax-curve-getStartPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        (vlax-curve-getEndPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                             ) ;_ end of or
                           ) ;_ end of lambda
                 ) ;_ end of function
                 line_list
               ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
       (grtext -1 (strcat "Обработка. Цикл - " (itoa (setq cycl (1+ cycl)))))
         (if couple
           (progn
             (setq chain_list (append couple chain_list))
             (setq line_list (vl-remove ln line_list))
             (setq ln (car chain_list))
           ) ;_ end of progn
           (setq line_list (cdr line_list))
         ) ;_ end of if
      ) ;_ end of while
      (setq loop nil)
    ) ;_ end of while
  ) ;_ end of progn
) ;_ end of if
  (setq chain_list (vl-remove ln1 chain_list))
  (if (= (type ln1) 'VLA-OBJECT)(vl-catch-all-apply 'vla-erase (list ln1)))
  (vl-cmdf "_.redraw")
  chain_list
)


;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;  KB:mark
;;;* Mark data base to allow KB:catch.
;;;*http://www.theswamp.org/index.php?topic=15863.0
(defun mip:mark (/ val)
   (setq val (getvar "cmdecho"))
   (setvar "cmdecho" 0)
   (if (setq *mip:mark (entlast))
      nil
      (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
             (setq *mip:mark (entlast))
             (entdel *mip:mark)
      )
   )
   (setvar "cmdecho" val)
   (princ)
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;  KB:catch
;;;* returns selection set of entities since last KB:mark.
;;;*
(defun mip:get-last-ss (/ ss tmp)
   (if *mip:mark
      (progn (setq ss (ssadd))
             (while (setq *mip:mark (entnext *mip:mark)) (ssadd *mip:mark ss))
             (command "._select" ss "")
             (setq tmp ss)
      )
      (alert "*mip:mark not set. \n run (mip:mark) before mip:get-last-ss.")
   )
)
;;;------------------------------------------------------------------
;;;------------------------------------------------------------------



(defun C:CSS ( / ss pda en fuzz)
 (vl-load-com)
 (if (and (setq en (car(entsel "\nВыбрать первую или последнюю линию в цепи :")))
          (wcmatch (cdr(assoc 0 (entget en))) "ARC,LINE,*POLYLINE"))
 (progn
 (if (null (setq fuzz (getdist "\nЗначение допуска < 0.01 >: ")))
   (setq fuzz 0.01))
 (setq ss (ssadd))
 (foreach item (setq lst (ChainSelectFromAny en (+ fuzz 1e-6)))
      (ssadd (vlax-vla-object->ename item) ss)
    )
  (mip:mark)
  (vl-catch-all-apply '(lambda()
    (setq pda (getvar "peditaccept"))
    (setvar "peditaccept" 1)
    (command "_pedit" "_M" ss "" "_j" "_j" "_b" fuzz "")
    (setvar "peditaccept" pda))
    )
   (setq lst (vl-remove-if 'vlax-erased-p lst))
  (if (setq ss nil ss (mip:get-last-ss))
    (progn
      (if lst
        (foreach item lst (ssadd (vlax-vla-object->ename item) ss)))
      (sssetfirst ss ss)))

  (setq ss nil)
  )
   )
  (princ)
  )
(defun C:CSP ( / ss pt1 pda lst fuzz)
 (vl-load-com)  
 (initget 1)
 (setq pt1 (getpoint "\nТочка начала объединения:"))
  (if (null (setq fuzz (getdist "\nЗначение допуска < 0.01 >: ")))
   (setq fuzz 0.01))
 
 (setq ss (ssadd))
 (foreach item (setq lst (ChainSelectFromAny (trans pt1 1 0)(+ fuzz 1e-6)))
      (ssadd (vlax-vla-object->ename item) ss)
    )
  (mip:mark)
  (vl-catch-all-apply '(lambda()
    (setq pda (getvar "peditaccept"))
    (setvar "peditaccept" 1)
    (command "_pedit" "_M" ss "" "_j" "_j" "_b" fuzz "")
    (setvar "peditaccept" pda))
    )
  (setq lst (vl-remove-if 'vlax-erased-p lst))
  (if (setq ss nil ss (mip:get-last-ss))
    (progn
      (if lst
        (foreach item lst (ssadd (vlax-vla-object->ename item) ss)))
      (sssetfirst ss ss)))
;;;  (setq ln (entlast))
;;;  (if (and (wcmatch (cdr(assoc 0 (entget ln))) "*POLYLINE")
;;;           (not(lwcl ln)))
;;;           (plineLW-reverse ln))
  (setq ss nil)
  (princ)
  )

(princ "\nНаберите CSP или CSS в командной строке")

Две команды
CSS - объединение путем выбора притива
CSP - объединение путем указания точки

[KAI]

>> VVA
Очень интересно! Но:

0. Мур-мур от команд надо-бы отключить.

1. CSS. В одном из моих отладочных чертежей вылезла следующая ошибка (правда там объекты отрисованы в разных UCS и ужасная мешанина из объектов):

Command: CSS
Выбрать первую или последнюю линию в цепи :
Значение допуска < 0.01 >:
; error: bad argument value: AcDbCurve 2130505112

2. CSS. 3DPoly следует исключать из набора, иначе получается следующая картина:

---3DPoly в конце цепочки------------

Command: css
Выбрать первую или последнюю линию в цепи :
Значение допуска < 0.01 >:
_.redraw
Command: _pedit Select polyline or [Multiple]: _M
Select objects: 9 found

Select objects:
Enter an option [Close/Open/Join/Width/Fit/Spline/Decurve/Ltype gen/Undo]: _j
Join Type = Both (Extend or Add)
Enter fuzz distance or [Jointype] <0.010>: _j
Enter join type [Extend/Add/Both] <Both>: _b
Join Type = Both (Extend or Add)
Enter fuzz distance or [Jointype] <0.010>: 0.010000000000000
8 segments added to polyline

Enter an option [Close/Open/Join/Width/Fit/Spline/Decurve/Ltype gen/Undo]:
Command: ._select
Select objects: 0 found
Select objects:

---3DPoly в начале----------------------

Command: CSS
Выбрать первую или последнюю линию в цепи :
Значение допуска < 0.01 >:
_.redraw
Command: _pedit Select polyline or [Multiple]: _M
Select objects: 10 found

Select objects:
Enter an option [Close/Open/Spline curve/Decurve/Undo]: _j
Invalid option keyword.

Enter an option [Close/Open/Spline curve/Decurve/Undo]: ._select
Invalid option keyword.
; error: Function cancelled

Enter an option [Close/Open/Spline curve/Decurve/Undo]:

3. CSP. Похоже точку надо указывать точно на узле объекта?

4. Для PEDITACCEPT лучше применять конструкцию:
(if (getvar "PEDITACCEPT");для 2006>>
(progn
(setq pda (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
)
)
Вдруг прогу запустят в acad 2005?

5. CSS. Кроме 3DPoly, думаю следует проверять еще и линии (они должны лежать в одной плоскости), а то получается, что грипсы загораются на всей цепочке, но это только видимость! Если последняя линия не в плоскости полилинии.

6. На мой взгляд, fuzz по умолчанию лучше бы сделать 0.0, будем приучать пользователей к точности.

[VVA]

> 0. Мур-мур от команд надо-бы отключить
Извини, не понял о чем речь
>1. CSS. В одном из моих отладочных чертежей вылезла следующая >ошибка (правда там объекты отрисованы в разных UCS и ужасная >мешанина из объектов):
Попробуй проверить этот чертеж _audit или _recover. Это помогло на том глючном файле, который ты присылал раньше.
>2. CSS. 3DPoly следует исключать из набора, иначе получается >следующая картина:
Пришли файл, т.к. 3dpoly исключаю

Код:

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

(setq line_list (vl-remove-if
                      '(lambda (x)
                         (eq "AcDb3dPolyline" (vla-get-objectname x))
                       ) ;_ end of lambda
                      line_list
                    ) ;_ end of vl-remove-if
    ) ;_ end of setq

>3. CSP. Похоже точку надо указывать точно на узле объекта?
Да
>4. Для PEDITACCEPT лучше применять конструкцию:
PEDITACCEPT появилась с 2004 Автокада. Не знаю, есть ли смысл ввводить проверку?

>5. CSS. Кроме 3DPoly, думаю следует проверять еще и линии (они >должны лежать в одной плоскости), а то получается, что грипсы >загораются на всей цепочке, но это только видимость! Если >последняя линия не в плоскости полилинии.
Здесь принцип такой: строится список объектов с совпадающими началом/концом и отдается на откуп _PEDIT _M. А уж сколь там контуров построит PEDIT одному Autodesk'у известно. Грипсами подсвечивается все, что получилось (или осталось). Это могут быть и несколько контуров, или (и) не объединенные LINE. Почему проскальзывают 3dpoly пока не понятно?

>6. На мой взгляд, fuzz по умолчанию лучше бы сделать 0.0, будем >приучать пользователей к точности.
Это правильно.

Еще терзают смутные сомнения в необходимости CSP.

[VVA]

> 0. Мур-мур от команд надо-бы отключить
Имеется ввиду CMDECHO?

[KAI]

>> VVA

>0. Именно CMDECHO.

>1. CSS. В одном из моих отладочных чертежей вылезла ошибка...

Audit and Recover не помогло.

>2. CSS. 3DPoly следует исключать из набора...

Если 3DPoly в конце - все OK.
А вот если в начале, то ....

>4. Для PEDITACCEPT

Отнюдь не все перешли еще на 2004>>

>5. CSS. Линии не в плоскости.

Может лучше подсветить грипсы для итоговой полилинии, а не для набора, передаваемого в PEdit?

> Еще терзают смутные сомнения в необходимости CSP.

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

И еще заметил. Если выбирать дугу, расположенную в середине цепочки, то CSS вроде логично объединяет дугу с последующими объектами (предыдущие не объединяются, предыдущий объект линия).
Но если выбрать линию (дугу) в середине цепочки, то объединяются выбранный объект и последующие и почему-то один предыдущий линия (или дуга при выборе дуги).

[VVA]

Вот новый вариант

Код:

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

;;* Утилита объединения набора линий в полилинию*
;;------------------------------------------------
;;Алгорити взят у ChainSelect Fatty
;;http://www.cadforyou.spb.ru/index.php?current_section=section_programs_page
;;Доработан до понимания ARC,PLINE,LINE
;;Для выполнения необходимо указать только точку
;; pt - точка в мировой системе координат !!!
;;    - или имя (ENAME VLA-OBJECT) начального примитива
;; fuzz - точность
;;Возвращает список vla объектов
(defun ChainSelectFromAny ( pt fuzz / chain_list couple ept line_list ln loop pda spt ss ln1 cycl)
(vl-load-com)
(cond ((= (type pt) 'ENAME)
       (setq ln (vlax-ename->vla-object pt)
             pt nil))
      ((= (type pt) 'VLA-OBJECT)(setq ln pt pt nil))
      (t nil))
(if (setq ss (ssget "_I") ss nil
          ss (ssget "_X" '((0 . "ARC,LINE,*POLYLINE")))) ;_ end of setq
  (progn
    (if pt (progn
      (setq ln1 (vla-addLine
            (if (and (zerop (vla-get-activespace (vla-get-activedocument (vlax-get-acad-object))))
                     (= :vlax-false (vla-get-mspace (vla-get-activedocument (vlax-get-acad-object))))) ;_ end of and
                      (vla-get-paperspace (vla-get-activedocument (vlax-get-acad-object)))
                      (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
               (vlax-3d-point pt)(vlax-3d-point (mapcar '- pt '(1 1 0)))))
        (setq ln ln1)))
     (setq spt (vlax-curve-getStartPoint ln)  ept (vlax-curve-getEndPoint ln))
    (setq line_list  (mapcar 'vlax-ename->vla-object
                             (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                     ) ;_ end of mapcar
          chain_list nil
          chain_list (cons ln chain_list)) ;_ end of setq
    (setq line_list (vl-remove-if
                      '(lambda (x)(eq "AcDb3dPolyline" (vla-get-objectname x)))
                      line_list)) ;_ end of setq
    (setq loop t cycl 0)
    (while loop
     (while
        (setq couple
               (vl-remove-if-not
                 (function (lambda (x)
                             ;; значение допуска 0.01 можно изменить по ситуации
                             ;; в зависимости от единиц черчения : 
                             (or (equal (vlax-curve-getStartPoint x)
                                        (vlax-curve-getStartPoint ln)
                                        fuzz      ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getStartPoint x)
                                        (vlax-curve-getEndPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        (vlax-curve-getStartPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        (vlax-curve-getEndPoint ln)
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                             ) ;_ end of or
                           ) ;_ end of lambda
                 ) ;_ end of function
                 line_list
               ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
       (grtext -1 (strcat "Обработка. Цикл - " (itoa (setq cycl (1+ cycl)))))
         (if couple (progn
             (setq chain_list (append couple chain_list))
             (setq line_list (vl-remove ln line_list))
             (setq ln (car chain_list))) ;_ end of progn
           (setq line_list (cdr line_list))) ;_ end of if
      ) ;_ end of while
      (setq loop nil)
    ) ;_ end of while
  ) ;_ end of progn
) ;_ end of if
  (setq chain_list (vl-remove ln1 chain_list))
  (if (= (type ln1) 'VLA-OBJECT)(vl-catch-all-apply 'vla-erase (list ln1)))
  (vl-cmdf "_.redraw") chain_list)

;;;* Mark data base to allow KB:catch.
;;;* http://www.theswamp.org/index.php?topic=15863.0
(defun mip:mark (/ val)
 (setq val (getvar "cmdecho"))(setvar "cmdecho" 0)
   (if (setq *mip:mark (entlast)) nil
      (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
             (setq *mip:mark (entlast))
             (entdel *mip:mark)))
   (setvar "cmdecho" val)(princ))
;;;* returns selection set of entities since last KB:mark.
(defun mip:get-last-ss (/ ss tmp val)
(setq val (getvar "cmdecho"))(setvar "cmdecho" 0)
(if *mip:mark (progn (setq ss (ssadd))
 (while (setq *mip:mark (entnext *mip:mark))(ssadd *mip:mark ss))
 (command "._select" ss "")(setq tmp ss ss nil));_progn
 (alert "*mip:mark not set. \n run (mip:mark) before mip:get-last-ss."));_if
 (setvar "cmdecho" val) tmp)
(defun C:CSS ( / ss pda en fuzz val)
 (vl-load-com)(setq val (getvar "cmdecho"))(setvar "cmdecho" 0)
 (if (and (setq en (car(entsel "\nВыбрать первую или последнюю линию в цепи :")))
          (wcmatch (cdr(assoc 0 (entget en))) "ARC,LINE,*POLYLINE")
          (setq en (vlax-ename->vla-object en))
          (/= "AcDb3dPolyline" (vla-get-objectname en))
          )
 (progn
 (if (null (setq fuzz (getdist "\nЗначение допуска < 0 >: ")))(setq fuzz 0))
 (setq ss (ssadd))
 (foreach item (setq lst (ChainSelectFromAny en (+ fuzz 1e-6)))
      (ssadd (vlax-vla-object->ename item) ss))
  (mip:mark)
  (vl-catch-all-apply '(lambda()
  (if (setq pda (getvar "PEDITACCEPT"))(progn
    (setq pda (getvar "peditaccept"))
    (setvar "peditaccept" 1)
    (command "_pedit" "_M" ss "" "_j" "_j" "_b" fuzz "")
    (setvar "peditaccept" pda))
    (command "_pedit" "_M" ss "" "_Y" "_j" "_j" "_b" fuzz ""))))
   (setq lst (vl-remove-if 'vlax-erased-p lst))
  (if (setq ss nil ss (mip:get-last-ss))(progn
      (if lst (foreach item lst (ssadd (vlax-vla-object->ename item) ss)))
      (setq fuzz 0)
      (while (setq en (ssname ss fuzz))
        (if (/= (cdr(assoc 0 (entget en))) "LWPOLYLINE")
          (ssdel en ss)
          (setq fuzz (1+ fuzz))))
      (sssetfirst ss ss)))
  (setq ss nil)
  )
   (princ "\nНеобходимо выбрать ОТРЕЗОК, ДУГУ, или Полилинию")
   )
(setvar "cmdecho" val)(princ)
)
(princ "\nНаберите CSS в командной строке")

[KAI]

>> VVA
Может это старческое брюзжание, но:

1. Болезнь отмены работы программы так и не преодолена, для отмены нужно 2 раза посылать команду U (это касается и программ комплекса pltools).
2. Все-таки логичнее будет, если пользователь выбирает объект вблизи будущего начала полилинии и к нему добавляются только объекты, примыкающие к концу этого объекта! Сейчас же, похоже, объединение выполняется в зависимости от направления исходных объектов, причем объединение происходит в режиме: все в одном направлении + один объект в противоположном.
3. Перед началом работы программы следует сбросить грипсы. Если после CSS снова ее запускаем (грипсы на предыдущей не сброшены), то после указания нового объекта для объединения получаем ошибку:

Command: CSS
Выбрать первую или последнюю линию в цепи :
Значение допуска < 0 >:

Invalid option keyword.

Invalid option keyword.
; error: Function cancelled

Enter an option [Close/Join/Width/Edit vertex/Fit/Spline/Decurve/Ltype
gen/Undo]:

А в целом, можно уже помещать ее в PLTolls.

[Profan]

Для VVA.
Панель "Толщины полилиний" лучше назвать "Ширина новой полилинии". А в программе не мешало бы учесть "DIMSCALE".

[VVA]

А в программе не мешало бы учесть "DIMSCALE"

С этого места поподробнее. На что может влиять DimScale?

[Profan]

Да вот, например. Архитекторы чертят план в масштабе 1:1, а выводить на печать будут из модели в масштабе 1:100. Все размерные величины (и тексты) соответственно увеличены в 100 раз. Для этого задается переменная "DIMSCALE" равная 100. В этих условиях ширина полилинии должна быть, для примера, не 0.5, а 50. Поэтому я и предположил, что, если "DIMSCALE" > 1, то и ширину полилинии надо устанавливать равной, скажем, 0.5 x (getvar "DIMSCALE"). Возможно, это спорный момент.

[VVA]

> Krieger №18

А как сделать реверс дуговых сегментов? Как ни крути тип линии в одну сторону направлен. AutoCAD2007

> Кулик Алексей aka kpblc №19

Это не сделать, наколько я помню, вообще никак. Только если изготовить новый тип линии и его назначать на полилинию

Может уже давно всем это известно, но для себя открыл недавно.
На дуговых сегментах полилинии тип линий может быть "вверх тормашками", причем реверс не помогает. Этот артефакт можно побороть, если в полилинии включить "генерацию типа линий".

[Кулик Алексей aka kpblc]

Вах-вах-вах! Позор на мою дурную голову! Я этого не знал! Вай-вай-вай!

[KAI]

А я посыплю голову пеплом!
p.s. А что уже начали проектировать газопроводы по дугам! Как я отстал!

[VVA]

>KAI это для наглядности. А так см. Krieger №18 (сварной шов).
Хотя с приходом пластика не удивлюсь, если в проекте будет написано "Трубу согнуть по месту"

[VVA]

>Profan # 76,78
По поводу учета толщины полилинии и DIMSCALE все решается через меню. Добавил панель "Ширина полилинии*Dimscale". Выложил в download. Обновление от 12.12.2007. Ссылка в 1 посте

[Profan]

Хорошо.

[plugins]

В файле новом файле dnl607.rar загружаемом со страницы http://dwg.ru/dnl/607 обновлены только history.txt, pltools.mnu и pltools.mns.
Все остальные файлы к сожалению от 13,03,2007

[VVA]

Да, пока так и есть. См. #83. Планирую обновления выложить после праздников. Основные отличия - переработаны алгоритмы оптимизации (прополки) полилинии + прополка (PL-VxRdc) восстанавливает дуговые сегменты. В данный момент переписываю алгоритм PL-DIV. Если успею, добавлю новую команду переноса сегмента полилинии по вертикали (а может и по горизонтали) с учем разных вертикальных и горизонтальных масштабов. Написал по заказу дорожников, для работы с профилями

[plugins]

Спасибо Вам огромное. Ваши программы увеличивают возможности автокада в несколько раз. Раньше пользовался ToolPack, теперь уже почти год Вашим пакетом. Работает отлично, без каких либо глюков и ошибок. Единственно где были проблемы, так это в программе VxRdc (с дугами, а также очень медленно работает при количестве точек порядка 7000). Проблему с дугами решил для себя заменив фрагмент:

if (or (and (vlax-method-applicable-p pl 'Getbulge)
(zerop (vla-GetBulge pl (1- n))))
(not (vlax-method-applicable-p pl 'Getbulge))
(and (vlax-method-applicable-p pl 'Getbulge)
(not (zerop (vla-GetBulge pl (1- n))))
pang
))

На

if (zerop (vla-GetBulge pl (1- n)))

Очень рад что после праздников может быть будет оптимизация.

[VVA]

Ну вот, свершилось. Выложил новую версию (обновление от 24.01.2008).
Кратко что нового:
Новые команды
PL-CSE -Объединение 2d полилиний по примитиву
PL-SgWidth -Изменить ширину сегмента полилинии

Переписан алгоритм PL-DIV и PL-DIVALL (теперь все делается геометрически)
Переписана и оптимизирована PL-VxRdc (теперь восстанавливает и дуговые сегменты)

[Profan]

Для VVA.
При выполнении команды PL-JOIN получил сообщение:

Код:

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

 
ERRNO # 0: no function definition: LIB:SELSET-TO-VLALIST

Хотел объединить 3 отрезка в полилинию. Не получилось. _PEDIT объединяет нормально.

[VVA]

Спасибо Владимир, Александр (KAI) мне уже сообщил. Обновил сборку (от 25.01.2008). Найденные Александром отсальные глюки (в основном при работе с тяжелыми [2d] полилиниями) устраню на досуге. Постараюсь не добавить новых.

[rus22]

(Продублировал с доунлоада)

А есть ли там функция объеденить в полилинию все отрезки на прямой? Или надо добавить?
Например делаем сечение втулки, кольца, итд, чтобы сделать разрез нужно линии объеденить, joynt конечно помогает но было бы проще одним щелчком или с промежуточным подтверждением, чтобы убедиться что не захвачены линии не входящие в этот объект

Загрузил прогу подключил, а то о чем писал один пост назад (объединение нескольких отрезков на одной прямой в одну сплошную полилинию у меня не получилось, команда (привожу дословно) ОБЪЕДИНИТЬ ВЫБРАННОЕ В 2d ПОЛИЛИНИИ , всего лишь ПРЕОБРАЗОВЫВАЕТ их, но НЕОБЪЕДИНЯЕТ!

Никаких ошибок не сообщает. АКАД2007русифицированный(неРУС)

[VVA]

Выложи сюда фрагмент чертежа.

[rus22]

Выкладываю
ACAD2007 (русификация)
Кстати стоит SPDS4 на всякий случай...

[Valery Brelovsky]

Для объединения в полилинию пользуюсь макросом. Данный макрос позволяет не вязку линий, в данном случае 10 в плане. Само собой, что линии на разных уровнях и с разными координатами по Z начала и конца линии, а также 3D линии.

^C^C(progn(setq ssnab (ssget "_I"))(while (not ssnab)(setq ssnab (ssget)))(command "_pedit" "_Multiple" ssnab "" "_Y" "_Join" 10.00 ""));

[Valery Brelovsky]

Сообщение от rus22 Выкладываю ACAD2007 (русификация) Кстати стоит SPDS4 на всякий случай...

Посмотрел и ваш пример. Если речь идёт о трёх отрезках так между концами отрезков почти 500 мм. Концы отрезков должны совпадать тогда они объедятся через редактирование полилилнии объединить. Команда _join она продлевает и объединяет если отрезки лежат на одной прямой.

[VVA]

>rus22 Можешь воспользаваться макросом #94. В pltools есть справке, а в енй написано

При объединени полилиний значение допуска (fuzz distance) принимается равным 0!.

В твоем случае невязку нужно задавать где-то 500 единиц.
Кстати твой отрезки прекрасно объединила новая команда PL-CSE с значением допуска 500

[rus22]

Блин сообщение с благодарностью куда-то делось

Спасибо за разъяснение ещё раз
эти функции казались очевидными (объединение строк) в необходимости однако с наскоку не получилось, поэтому может в хелп стоит добавить пару строк, да и вообще комментировать в каких случаях большинство участвовавших каким-либо образом в разработке этого хорошего набора его применяют

[rus22]

>>>>очевидными (объединение строк)

Пардон ошибся - линий с разрывами на одной прямой

[Владимир.]

Сообщение от KAI А что уже начали проектировать газопроводы по дугам!

Всю жизнь был "радиус естественного изгиба" у подземных трубопроводов

[Red Nova]

VVA, Только что узнал что PLtools это твоих рук творение. Я без нее давно AutoCAD не представляю. Спасибо большое.
Есть кое что в PLtools, что мне хотелось бы слегка подкорректировать. Когда добавляешь вершину в полилинию почему-то работает только привязка nearest, тогда как очень бывает нужно чтобы работали и другие привязки. Извиняюсь если этот вопрос уже обсуждали. Форум весь я не читал.

[VVA]

Это связано с тем, что за один раз указывается точка и по этой точке выбирается полилиния. Привязки действуют, но только временные. Нажми Shift+ правый клик и выбери нужную.

[Red Nova]

Есть идея новой команды. Часто бывает нужно удалить один из сегментов полилинии, нажал на сегмент и он удален. Может такое уже было, но я не встречал.

[Кулик Алексей aka kpblc]

_.break, что ли?

[VVA]

>Red Nova И что остается потом?
Если 2 полилинии, то _.break

[zenon]

Сообщение от Кулик Алексей aka kpblc _.break, что ли?

похоже, но наверно хочется чтоб простым указаниием мышкой, что-то вроде этого

[Елпанов Евгений]

Сообщение от zenon похоже, но наверно хочется чтоб простым указаниием мышкой, что-то вроде этого Вложение 4277

команда trim из экспрессов, делает все именно так...

[zenon]

Сообщение от Елпанов Евгений команда trim из экспрессов, делает все именно так...

Угу, вот только еще удаляет то что не надо удалять, да и 2 клика нужно

[Red Nova]

zenon, Во во, именно так.
Елпанов Евгений, Енто где, я не нашел в express такого

[Елпанов Евгений]

Сообщение от Red Nova zenon, Во во, именно так. Елпанов Евгений, Енто где, я не нашел в express такого

Пример:

[zenon]

3 клика, нужен 1

[Red Nova]

Елпанов Евгений, А если линии разных полилиний пересекаются? Trim не всегда то.

[Кулик Алексей aka kpblc]

Ну если сильно хочется одним кликом, попробуйте:

Код:

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

(defun c:mod-break (/ *error* adoc ent pt_near pt_prev pt_next param)
  (defun *error* (msg)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vl-load-com)
  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-startundomark
  (if
    (and
      (not (vl-catch-all-error-p
             (vl-catch-all-apply
               '(lambda () (setq ent (entsel "\nУкажите полилинию <Отмена> : ")))
               ) ;_ end of vl-catch-all-apply
             ) ;_ end of vl-catch-all-error-p
           ) ;_ end of not
      (= (cdr (assoc 0 (entget (car ent)))) "LWPOLYLINE")
      ) ;_ end of and
     (progn
       (setq pt_near (cadr ent)
             ent     (vlax-ename->vla-object (car ent))
             pt_near (vlax-curve-getclosestpointto ent pt_near)
             pt_prev (vlax-curve-getpointatparam
                       ent
                       (setq param (fix (vlax-curve-getparamatpoint ent pt_near)))
                       ) ;_ end of vlax-curve-getPointAtParam
             pt_next (vlax-curve-getpointatparam ent (1+ param))
             ) ;_ end of setq
       (command "_.break"
                "_none"
                (vlax-vla-object->ename ent)
                "_none"
                pt_prev
                "_none"
                pt_next
                ) ;_ end of command
       ) ;_ end of progn
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Код особо не гонял, предупреждаю сразу.

[Лентяй]

Когда kpblc вылезает с entsel'ом с последующим vl-ename->vla-jbject'ом, у меня начинается изжога с скердцебиением. А потому - мои бесценные два цента.

Код:

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

(defun c:mod-break (/ *error* adoc util ent pt asp param par_end pts add)
  (defun *error* (msg)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        util (vla-get-utility adoc))
  (vla-startundomark adoc)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply
               '(lambda () (vla-getEntity util 'ent 'pt "\nУкажите полилинию <Отмена> : ")))));not
     (progn
       (setq asp (vla-ObjectIDToObject adoc (vla-get-OwnerID ent))
             pt (vlax-curve-getclosestpointto ent (vlax-safearray->list pt)))             
       (vla-InitializeUserInput util 128 "Начало Конец")
       (setq kw (vla-getKeyword util "Отрезать [Начало/Конец] <Конец>: "))
       (if (= kw "") (set kw "Конец")) 
       (if (= kw "Конец") (setq param 0 par_end (vlax-curve-getparamatpoint ent pt))
         (setq param (1+ (fix (vlax-curve-getparamatpoint ent pt)))
               par_end (vlax-curve-getendparam ent)));if
       (while (<= param par_end)
         (setq pts (append pts (vlax-curve-getpointatparam ent param))
               param (1+ param)));while
       (if (= (vla-get-objectname ent) "AcDbPolyline")
         (setq pts (vl-remove-if '(lambda (x) (= x 0.0)) pts)
               add vla-addLightWeightPolyline)
         (setq add vla-addPolyline));if
       (add asp (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble (cons 0 (1- (length pts)))) pts)))
       (vla-delete ent)) ;_ end of progn
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

Программа работает вперед и назад, kpblc'овские фрагменты оставилены без изменения.

[Profan]

Получил такое сообщение:

Код:

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

 
Команда: MOD-BREAK
Укажите полилинию <Отмена> :
Команда: Отрезать [Начало/Конец] <Конец>: Н
Команда: Ошибка Automation. Недопустимый аргумент coordinates в Coordinates 
property
Команда:

AutoCAD 2006 РУС.
Программа Алексея работает нормально.

[Кулик Алексей aka kpblc]

Лентяй, ну побереги уж себя, нам и так без тебя скучно

[Red Nova]

Кулик Алексей aka kpblc, Работает, спасибо.


Лентяй,

Код:

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

Command:
MOD-BREAK
Укажите полилинию <Отмена> :
Command: Отрезать [Начало/Конец] <Конец>: Н

Command: bad argument type: symbolp ""
Command:
Command:
MOD-BREAK
Укажите полилинию <Отмена> :
Command: Отрезать [Начало/Конец] <Конец>: К

Command: bad argument type: symbolp ""
Command:

Вот что пишет у меня при использовании твоего варианта. Задумка для меня осталась тайной.

[Лентяй]

Profan, я по скудости личного кошелька пользуюсь все еще AutoCAD-2005, поскольку на работе мне АвтоКад не положен. А посему. активно пользуюсь удобства ради одним собственноручно открытым багом - заменой имени функции именем переменной. В данном случае, например,

Код:

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

(setq add vla-addLightWeightPolyline)

и

Код:

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

(setq add vla-addPolyline)

Иногда это позволяет сэкономить довольно длинные идентичные куски кода. Видимо, в версиях выше 2005-й этот фокус уже не проходит. Сочувствую всем от этого бага излеченным. В качестве утешения примите "правильный" код.

Код:

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

 (defun c:mod-break (/ *error* adoc util ent pt asp param par_end pts)
  (defun *error* (msg)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        util (vla-get-utility adoc))
  (vla-startundomark adoc)
  (if (not (vl-catch-all-error-p (vl-catch-all-apply
               '(lambda () (vla-getEntity util 'ent 'pt "\nУкажите полилинию <Отмена> : ")))));not
     (progn
       (setq asp (vla-ObjectIDToObject adoc (vla-get-OwnerID ent))
             pt (vlax-curve-getclosestpointto ent (vlax-safearray->list pt)))             
       (vla-InitializeUserInput util 128 "Начало Конец")
       (setq kw (vla-getKeyword util "Отрезать [Начало/Конец] <Конец>: "))
       (if (= kw "") (set kw "Конец")) 
       (if (= kw "Конец") (setq param 0 par_end (vlax-curve-getparamatpoint ent pt))
         (setq param (1+ (fix (vlax-curve-getparamatpoint ent pt)))
               par_end (vlax-curve-getendparam ent)));if
       (while (<= param par_end)
         (setq pts (append pts (vlax-curve-getpointatparam ent param))
               param (1+ param)));while
       (if (= (vla-get-objectname ent) "AcDbPolyline")
         (progn (setq pts (vl-remove-if '(lambda (x) (= x 0.0)) pts))
           (vla-addLightWeightPolyline asp
             (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble
                                                       (cons 0 (1- (length pts)))) pts))));progn
         (vla-addPolyline asp
             (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble
                                                       (cons 0 (1- (length pts)))) pts))));if
       (vla-delete ent)) ;_ end of progn
     ) ;_ end of if
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun

[Profan]

Лентяй, мой личный кошелек тоже скуден, поэтому дома я работаю на чем попало, хоть на 2009. На работе мне продукт положен, однако, из-за скудости кошелька руководителя конторы приходится тоже работать на чем попало, хоть на 2009. Но это временное явление. Стремясь стать независимым служащим, я уже приобрел две коробки с Windows XP HE.

[Cfytrr]

Приветствую вас, а можно сделать так чтоб после запуска команда PL-CSE с допуском например 3.5, при повторном запуске сохраняла ранее введенное значение допуска <3.5>, а не сбрасывала его на <0>?
И незнаю, насколько это возможно, сделать алгоритм соединения зависимым не только от "допуска", но и от min величины "угла" примыкания соединительного отрезка.

[VVA]

Про запоминание значения не проблема, а про "угол" надо подумать. Вся проблема в алгоритме.

[VVA]

По просьбе отсюда
Утилита объединения набора линий в полилинию
Должна выбирать все (сначала и с конца) найденные примитивы в цепочку
см. #140

[Tonic]

У меня в AutoCAD 2005 (и в 2008) всё равно не хочет объединять все сегменты, даже если первый или последний выбрать! То часть сегментов определит, то только слева направо от выделенного. Ну а Bricscad вообще отказался работать =)

[VVA]

Изменил код в #121 Пробуй снова. BricsCad не поддерживает Visual LISP

[Кулик Алексей aka kpblc]

Сообщение от VVA Изменил код в #121 Пробуй снова. BricsCad не поддерживает Visual LISP

Не совсем так. 8-ка ActiveX уже поддерживает. Правда, не в полном объеме, там надо практически построчно проходить выполнение.

[Tonic]

Заработало! Спасибо!

[Red Nova]

VVA, Мне просто стало интересно, ты время от времени пополняешь PLTools такими лиспами, как на #121, или нет? Если да, то мне давно пора сделать апгрейт.

[KAI]

Запускаем:
Command: css

Выбрать линию в цепи :
Значение допуска < 0.01 >:
_.redraw
Command: _pedit Select polyline or [Multiple]: _M
Select objects: 10 found

Select objects:
Enter an option [Close/Open/Join/Width/Fit/Spline/Decurve/Ltype gen/Undo]: _j
Join Type = Both (Extend or Add)
Enter fuzz distance or [Jointype] <0.010>: _j
Enter join type [Extend/Add/Both] <Both>: _b
Join Type = Both (Extend or Add)
Enter fuzz distance or [Jointype] <0.010>: 0.010000000000000
9 segments added to polyline

Enter an option [Close/Open/Join/Width/Fit/Spline/Decurve/Ltype gen/Undo]:
Command: ._select
Select objects: 1 found

Select objects:
Command:


Мур-мур бы убрать...
И в добавок. Гораздо интереснее было бы соединять в полилинию только те объекты, которые ближе к выбранному концу объекта, а с другого конца объекта их игнорировать.
Или может быть оформить это опциями (All по умолчанию, Next - только ближайшие к концу).
И по окончанию работы программы - статистику (сколько объединено объектов).
p.s. В PL-CSE (pltools) то же было бы неплохо "загрипсовать объект".

[bonnata]

Спасибо авторам за ОЧЕНЬ нужные программы!
А возможно ли такое? Сгруппировать полилинию с пересекающими ее объектами (отрезками, блоками). при этом разворачивая углы полилинии на 180 (очень бы помогло для построения развернутого плана трубопроводов).

[VVA]

В №121 обновил команду CSS. По моему получилось неплохо. Можно рассатривать как кандидат на замену PL-CSE.

[Tonic]

Bricscad то вылетает, то зависает =)

[VVA]

>Tonic см. #124. Я пока ориетнируюсь на Автокад.

[KAI]

>>VVA
А где _VXGRDRAW?

Выбрать линию в цепи :; error: no function definition: _VXGRDRAW

Добавьте, пожалуйста!
p.s. Опции устраивают.
p.p.s. А когда будет обновление сборки pltools. Народ любит обновления любимых программ.

[VVA]

_vxgrdraw mip_grdraw добавил в #121. Если устраивают опции, их содержание и вид, то обновлю функционал PL-CSE.

[Cfytrr]

Сообщение от VVA команду CSS... Можно рассатривать как кандидат на замену PL-CSE.

Лично меня PL-CSE устраивает больше.
1. CSS прекращает соединять элементы в цепочку после соединения "разрыва".
2. В CSS очень муторно высматривать куда ткнуть мышой чтоб угадать ближайшую вершину в отрезке, в PL-CSE просто указываешь первый и все.

[KAI]

>> VVA (не сочтите занудой, но...)
Теперь потерялась функция pl(двоеточие)DTR
(извини, вставил сам для просмотра)
1. По умолчанию лучше дать опцию "Обе"
2. Строить цепочку от ближайшей точки [Ближайшая/Противоположная/Обе] <Ближайшая>: - здесь чуть-чуть не по русски. Может так:
Соединять от ближайшей точки [Ближайшей/Противоположной/Все]
3. Застарелая проблема. Пока 2 раза не нажмешь U - действие команды не отменится.
4. Строить цепочку от ближайшей точки [Ближайшая/Противоположная/Обе]
<Ближайшая>:
Нажимае Esc, далее:
*Cancel*
; error: Function cancelled
Это уже лишнее, пользователь и так ее явно прервал.
5. Выбрать линию в цепи :
Строить цепочку от ближайшей точки [Ближайшая/Противоположная/Обе] <Ближайшая>: G
Invalid option keyword. (Но тем не менее все идет далее...)
Значение допуска < 0.01 >:
6. Значение допуска лучше задать 0.0 (будем приучать пользователей к точности).
7. Рисуем несколько линий, у одних задаем в общем узле отметку Z отличную от 0. Запускаем программу по опции "Обе". Грипсы по всей цепочке линий (пользователь думает, что соединено!), но соединяет, естественно только линии с Z=0.
8. И наконец, было бы неплохо, если последняя опция, выбранная пользователем, сохраналась, например, он выбрал "Ближайшая", вот и пусть при повторном запуске программы ему и была предложена эта опция.

[Red Nova]

VVA, По поводу #121. У меня не работает.
Запускаю команду CSS

Command: css Выбрать линию в цепи :; error: no function definition: PLTR Command:

А как должно в правильном варианте быть?
Я путаю что должна делать CSS, а что DTR.
При команде DTR

Command: dtr DS> Pick Starting Point: DS> Angle/Close/Flip/Intersect/Left/Right/North/South/East/West <Distance>: Command:

Я не могу понять что там к чему.

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

[Red Nova]

Написал и обнаружил что PL : DTR отображается как PLTR. Забавно

[VVA]

> Red Nova Я добавил эти ф-ции в #121. А вообще они все есть в pltools, поэтому достаточно вызвать любую команду pltools, а затем CSS. У меня все грузится автоматом, поэтому кое-какие библиотечные ф-ции вечно забываю.

[Red Nova]

VVA, Ты меня только запутал.

А вообще они все есть в pltools, поэтому достаточно вызвать любую команду pltools, а затем CSS.

Что конкретно есть в pltools.
Что должна делать команда CSS? У меня pltools есть, вызываю любую команду потом CSS, и нечего

Command: PL-VxAdd Укажите точку разрыва [отмени U/выход X] <выход> : css Point or option keyword required.

А как соеденить находящиеся в цепочке объекты я так и не понял.

[VVA]

Новая версия CSS. С учетом замечаний KAI кроме №7 и Red NOva #145

Код:

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

;;* Утилита объединения набора линий в полилинию*
;;* Должно выбирать все (сначала и с конца) найденные примитивы в цепочку)
;;------------------------------------------------
;;Алгорити взят у ChainSelect Fatty
;;http://www.cadforyou.spb.ru/index.php?current_section=section_programs_page
;;Доработан до понимания ARC,PLINE,LINE
;;Для выполнения необходимо указать только точку
;; pt - Список точек для выбранных примитивов в МСК !!!
;; fuzz - точность
;;Возвращает список vla объектов
(defun ChainSelectFromAny1 ( pt obj fuzz / chain_list couple line_lst ln ss cycl line_list )
(vl-load-com)
(if (setq ss (ssget "_I")
          ss nil
          ss (ssget "_X" '((0 . "ARC,LINE,*POLYLINE")))
    ) ;_ end of setq
  (progn
    (setq line_lst  (mapcar 'vlax-ename->vla-object
                             (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                     ) ;_ end of mapcar
          chain_list nil
          chain_list (list obj)
    ) ;_ end of setq
    (setq line_lst (vl-remove-if
                      '(lambda (x)
                         (eq "AcDb3dPolyline" (vla-get-objectname x))
                       ) ;_ end of lambda
                      line_lst
                    ) ;_ end of vl-remove-if
    ) ;_ end of setq
     (setq line_lst (vl-remove obj line_lst))
    (setq cycl 0 line_list line_lst)
    (foreach pt_Pattern pt
     (while
        (setq couple
               (vl-remove-if-not
                 (function (lambda (x)
                             ;; значение допуска 0.01 можно изменить по ситуации
                             ;; в зависимости от единиц черчения : 
                             (or (equal (vlax-curve-getStartPoint x)
                                        pt_Pattern
                                        fuzz      ;<--- допуск 
                                 ) ;_ end of equal
                                 (equal (vlax-curve-getEndPoint x)
                                        pt_Pattern
                                        fuzz     ;<--- допуск 
                                 ) ;_ end of equal
                             ) ;_ end of or
                           ) ;_ end of lambda
                 ) ;_ end of function
                 line_list
               ) ;_ end of vl-remove-if-not
        ) ;_ end of setq
       (grtext -1 (strcat "Обработка. Цикл - " (itoa (setq cycl (1+ cycl)))))
       (if couple
           (progn
             (setq chain_list (cons (car couple) chain_list))
             (setq ln (car chain_list))
             (setq line_list (vl-remove ln line_list))
             (setq pt_Pattern (if (equal pt_Pattern (vlax-curve-getStartPoint ln) 1e-6)
                                (vlax-curve-getEndPoint ln)
                                (vlax-curve-getStartPoint ln)
                                )
                   )
           ) ;_ end of progn
         ) ;_ end of if
      )
   )
  ) ;_ end of progn
) ;_ end of if
chain_list
)
;;;Ф-ция переводит градусы в радианы
;;;( pl:DTR a)
(defun pl:DTR (a)(* pi (/ a 180.0)))
;;;---------------------------------------------
;;;Ф-ция переводит радианы в градусы
;;;( R2D a)
(defun pl:RTD (a)(/ (* a 180.0) pi))
(defun mip_grdraw ( ptdraw ang color / pt1 pt2 )
  (setq pt1 (polar ptdraw (+ ang (pl:DTR 135)) (* 0.05 (getvar "VIEWSIZE"))))
  (setq pt2 (polar ptdraw (+ ang (pl:DTR 225)) (* 0.05 (getvar "VIEWSIZE"))))
  (grvecs (list color pt1 ptdraw ptdraw pt2))
  )
(defun _vxgrdraw ( ptdraw color / ang pt11 pt12 pt21 pt22 len )
  (setq len (* 0.03 (getvar "VIEWSIZE"))
       ang 0
       pt11 (polar ptdraw (+ ang (pl:DTR 225)) len)
       pt12 (polar ptdraw (+ ang (pl:DTR 45)) len)
       pt21 (polar ptdraw (+ ang (pl:DTR 315)) len)
       pt22 (polar ptdraw (+ ang (pl:DTR 135)) len))
  (grvecs (list color pt11 pt12 pt21 pt22))
  )
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;  KB:mark
;;;* Mark data base to allow KB:catch.
;;;*http://www.theswamp.org/index.php?topic=15863.0
(defun mip:mark (/ val)
   (setq val (getvar "cmdecho"))
   (setvar "cmdecho" 0)
   (if (setq *mip:mark (entlast))
      nil
      (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
             (setq *mip:mark (entlast))
             (entdel *mip:mark)
      )
   )
   (setvar "cmdecho" val)
   (princ)
)
;;;-----------------------------------------------------------------------------------
;;;-----------------------------------------------------------------------------------
;;;  KB:catch
;;;* returns selection set of entities since last KB:mark.
;;;*
(defun mip:get-last-ss (/ ss tmp)
   (if *mip:mark
      (progn (setq ss (ssadd))
             (while (setq *mip:mark (entnext *mip:mark)) (ssadd *mip:mark ss))
             (command "._select" ss "")
             (setq tmp ss)
      )
      (alert "*mip:mark not set. \n run (mip:mark) before mip:get-last-ss.")
   )
)
;;;------------------------------------------------------------------
;;;------------------------------------------------------------------
 
(defun C:CSS ( / ss en fuzz obj pt pt1 len dst ptother what lst *error*)
 (vl-load-com)
 (defun *error* (msg)(princ msg)
   (vla-EndUndoMark(vla-get-ActiveDocument (vlax-get-acad-object)))(princ))
 (vla-StartUndoMark(vla-get-ActiveDocument (vlax-get-acad-object))) 
 (setvar "cmdecho" 0) 
 (if (and (setq en (entsel "\nВыбрать линию в цепи :"))
          (wcmatch (cdr(assoc 0 (entget (car en)))) "ARC,LINE,*POLYLINE")
          (setq obj (vlax-ename->vla-object (car en)))
          (cond ((=(vla-get-ObjectName obj) "AcDb3dPolyline")
                 (princ "\n3d Полилиния. ") nil)
                ((and (=(vla-get-ObjectName obj) "AcDbLine")
                      (not(equal (last(cdr(assoc 10 (entget(car en)))))
                             (last(cdr(assoc 11 (entget(car en)))))
                             1e-9
                             )
                          )
                      )
                 (princ "\nОтрезок. Разные координаты Z. ") nil)
                ((and (=(vla-get-ObjectName obj) "AcDb2dPolyline")
                     (member (vla-get-Type obj) '(1 2 3)))
                 (princ "\n2d сглаженная полилиния. ") nil)
                (t t)
                )
          )
 (progn
 (setq pt1 (trans (cadr en) 1 0))  
 (setq pt1 (vlax-curve-getclosestpointto obj pt1))
 (setq len (vlax-curve-getDistAtParam obj (vlax-curve-getEndParam obj)))
 (setq dst (vlax-curve-getDistAtPoint obj pt1))
 (if (<= dst (- len dst))
   (setq pt (vlax-curve-getStartPoint obj) ptother (vlax-curve-getEndPoint obj))
   (setq pt (vlax-curve-getEndPoint obj) ptother (vlax-curve-getStartPoint obj))
   )
  (_vxgrdraw (trans pt 0 1) -1)
(mip_grdraw (trans pt1 0 1)
  (angle (trans pt1 0 1)(trans pt 0 1)) 1)
 (initget "Ближайшая Противоположная Обе Nearest Opposite Both _Nearest Opposite Both Nearest Opposite Both")
 (princ "\nСтроить цепочку от ближайшей точки [Ближайшая/Противоположная/Обе] <Обе>:")
 (setq what (getkword))
 (cond ((= what "Opposite")
        (setq pt (list ptother))
        (vl-cmdf "_.redrawall")
        (_vxgrdraw (trans ptother 0 1) -1)
        (mip_grdraw (trans pt1 0 1)
  (angle (trans pt1 0 1)(trans ptother 0 1)) 1)
        )
       ((= what "Nearest") (setq pt (list pt)))
       (t (setq pt (list pt ptother)))
       )
 
 (if (null *FUZZ*)(setq *FUZZ* 0.0))
 (princ "\nЗначение допуска < ")(princ *FUZZ*)(princ " >: ")
 (if (null (setq fuzz  (getdist)))
   (setq fuzz *FUZZ*))
 (setq *FUZZ* fuzz)
 (vl-cmdf "_.redrawall")
 (setq ss nil ss (ssadd (car en)))
       
 (setq lst (ChainSelectFromAny1 pt obj (+ fuzz 1e-6)))
 (foreach item lst
      (ssadd (vlax-vla-object->ename item) ss)
    )
  (mip:mark)
  (vl-catch-all-apply '(lambda()
    (setq pda (getvar "peditaccept"))
    (setvar "peditaccept" 1)
    (command "_pedit" "_M" ss "" "_j" "_j" "_b" fuzz "")
    (setvar "peditaccept" pda))
    )
   (setq lst (vl-remove-if 'vlax-erased-p lst))
  (if (setq ss nil ss (mip:get-last-ss))
    (progn
      (if lst
        (foreach item lst (ssadd (vlax-vla-object->ename item) ss)))
      (sssetfirst ss ss)))
  (setq ss nil)
  )
   (princ " Невожможно преобразовать в полилинию")
   )
 (vla-EndUndoMark(vla-get-ActiveDocument(vlax-get-acad-object)))
  (princ)
  )
(princ "\nНаберите CSS в командной строке")

[nastasja]

Мне нужно преобразовать полилинию в дуговой сегмент. ПРоги я отсюда скачала, сделала, как написано в сопроводиловке txt, но что значит "активировать панель" я не поняла. Раньше я программированием и 3D не занималась, но теперь диплом делаю, так что приходится осваивать..

[Cfytrr]

VVA, у меня по прежнему после соединения разрыва между отрезками #140 останавливатся и остальные отрезки не соединят
AutoCad 2005, 2009

[VVA]

>nastasja "активировать панель" - значит сделать панельку с кнопками видимой.

Мне нужно преобразовать полилинию в дуговой сегмент

требует дополнительного разъяснения. Что-то мне подсважывает, что для твоих задач _pedit'a за глаза хватит
>Cfytrr Кинь примерчик на почту.

[Red Nova]

VVA лисп с #140 работает нормально. Спасибо.

P.S. Отлично придумано с допуском

[Red Nova]

VVA, Есть пожелание по поводу CSS. Обычно когда соединяют объект к другому, то свойства первого передаются второму. Только что пробовал соединить дугу к полилиние (первый объект - дуга). Так в этом случае соединенная полилиния принимает свойства второго объекта. Лучше бы было если бы тут все было как в обычном join.

[VVA]

Здесь обсуждаются предложения. Это не значит что я немедленно брошусь все исправлять/дописывать. У меня тоже есть работа. Предложения берутся на заметку и исправляются/доделываются в следующей версии. Если это действительно очень важно, то обновил код в #140 с учетом твоих пожеланий и замечаний KAI #135, кроме №7

[Red Nova]

Не стреляй, здаюсь. Просто думал ты не счел это важным, раз не ответил.
Удалил постыдное сообщение, раз оно тебя так разозлило.
Лисп опробовал, все работает.
Большое спасибо.

[Nikolays]

да эти PLTOOLS,у меня 2006 КАД,эти все функции у меня работали в один прекрасный момент перестали работать,из за чего не пойму

[VVA]

Nikolays,
1. Что выдает при попытке вызвать команду?
2. Попробуй в командной строке набрать _appload и загрузить pltools.fas из папки PLTOOLS, потом вызвать какую-либо команду
3. Тоже самое по п.2, только загрузи файл pltools.lsp из подпапки LISP папки PLTOOLS

[Nikolays]

это всё я сделал,но при выполнении команд выдаёт сообщение:ERRNO # 0: no function definition: nil,Выберите Полилинию, Сплайн или Отрезок для реверса <хватит>:ERRNO # 2: no
function definition: VLAX-ENAME->VLA-OBJECT,*error* functionAutoCAD variable setting rejected: "CMDECHO" nil

[VVA]

В PLTOOLS (vl-load-com) грузится автоматом при загрузке файла.
Nikolays,
1. Скопируй или набери в командной строке (vl-load-com)
2. Затем (vlax-get-acad-object)
Должно возвращать что-то типа #<VLA-OBJECT IAcadApplication 00c2eb8c>
А у тебя что пишет?

[Nikolays]

при запуске команды"vl-load-com"выдаёт сообщение:Команда: vl-load-com
Unknown command "VL-LOAD-COM". Press F1 for help
при запуске команды"vlax-get-acad-object":выдаёт сообщение:Unknown command "VLAX-GET-ACAD-OBJECT". Press F1 for help.

[Nikolays]

при копировании и вставке (vlax-get-acad-object)
выдаёт:
#<VLA-OBJECT IAcadApplication 00c2db8c>

[VVA]

Что еще могу посоветовать:
1. Попробуй скачай последнюю версию
2. Создай новую учетную запись и попробуй в ней
3. попробуй pltools на другой машине

[Nikolays]

У меня последняя версия pltools,на других машинах работает без проблем,да и на этой машине работали все команды,а потом перестали

[KAI]

Сообщение от Nikolays У меня последняя версия pltools,на других машинах работает без проблем,да и на этой машине работали все команды,а потом перестали

Мистика, однако!

[Red Nova]

VVA,

Попробуй скачай последнюю версию

Кстати, а где ее качать?

[VVA]

Red Nova, см. пост #1
Nikolays, Еще пара советов в порядке предпостения:
1. Попробуй на своей машине завести новую учетную запись и попробывать там pltools (рекомендация #154 №2)
2. Попробывать удалить Автокад и поставить снова.

[VVA]

Offtop: Теперь 1-й пост прикрепляется вверху каждой страницы. Удобно

[Nikolays]

с новой учётной записью Pltools тоже не работает

[VVA]

А п.2 из #158 ?

[Димас]

а такое добавить не хотите?
бывает нужно провести часть полилинии по уже существующему контуру/контурам
хотелось бы нечто очень юзер-френдли - рисую полилинию стандартной командой, нужно провести по существующему контуру, запускаю команду, тыкаю начальную точку, тыкаю конечную, продолжаю рисовать полилинию.
Будете такое добавлять?)

[KAI]

>> VVA
Подумал-подумал, посоветовался с гл.геологом, и решил: действительно, будет полезно иметь в PLTOOLS такую штуку.

[KAI]

Забыл ТУ:
Координаты начала новой полилинии по первой точке исходной полилинии (координаты в UCS).
Далее точки новой полилинии должны идти в плоскости UCS, естественно, что если прежняя полилиния не находится в этой плоскости, то ее точки должны проецироваться на плоскость UCS.
Для нас дуги на исходной полилинии можно игнорировать, но лучше их сохранять, мало-ли кому это важно.
Начало не мешало-бы пометить крестиком.
Привязка при указании 1-й и 2-й точки на исходноий полилинии по умолчанию - END, но возможны и другие, выбираемые пользователем (NEA, MID и др.)

[VVA]

Димас, KAI, Вычлинить из готовой полилинии набор сегментов не проблема. По принципу PL-CLONE, только там выделяешь сегменты, а здесь начало и конец. Я пока не знаю как "скрестить" стандартную команду рисования полилинии, возможность добавления некоторого количеста вершин и затем опять продолжения рисования полилинии ?

[KAI]

>>VVA
А если немного упростить вышесказанное (кстати, на это и указывал Димас):
1. Начинаем на исходной полилинии.
2. Задаем 2-ю точку на исходной полилинии.
3. Дальнейшее указание точек новой полилинии (опции команды PLINE не нужны, показ новой виртуальной полилинии весьма приветствуется), то есть только прямые сегменты для новой полилинии , + опция 'Замкнуть'.
4. При отказе от новой точки или по Close отрисовывается новая полилиния (сначала от 1-й до 2-й точки исходной, а затем, по заданным пользователем точкам). Можно по Esc (+ опция Exit) сделать так, чтобы новая полилиния не отрисовывалась.

[MIP]

VVA сейчас в отпуске отвечу за него.
1. Мое мнение всунуть эту возможность в именно в стандартную команду отрисовки полилинии не получется, я видел как это работает в другой программе, там собственная команда создания полилиний (контуров) с возможностью трассировки по другому контуру.
2. Скорее всего прийдется писать заменитель стандартной команды. Выглядеть он будет примерно так:
- Будут запрашиватся точки вершин будущей полилинии, с опциями полилинии, но в место полилинии создавть временную геометрию (отрезки, дуги) с включением их в набор
- Будет опция трассировки по существующему контуру, т.е. от точки начала трассировки по контуру до точки конца трассировки по контуру
- В случае замкнутого контура дополнительно прийдется задать сторону по которой пройдет трассировка, создается временное построение трассировки по контуру включаемое в набор
- далее продолжаем ввод координат вершин полилинии с опциями полилинии или трассировку по другому контуру, опять же со временными построениями с включениями в набор.
- по окончанию построений все объединяется в одну полилинию.
В качетсве настроек цвет временных построений и толщина (вес) линий для визуального наблюдения.
Сложности будут при переходе трассировки с одного контура на другой в точке их пересечения (может быть точкой пересечения множества контуров), возможно дополнительно прийдется указать тот контур по которому будет осуществлятся трассирование далее. Кроме того возможно понадобится трассировка по контуру блока, сплайна и т.п.
Но в общем цель ясна, покожу VVA на примерах.
Кто хочет или знает как лучше дополняйте.

[Do$]

В выложенном архиве нет такого файла:
pltools.cui -- меню для подгрузки в AutoCAD с 2006 включительно

[VVA]

Do$, Спасибо, выйду из отпуска - исправлю. А пока можно делать так, как написано в readme.txt:

========= Как пользоваться ========= 1. Поместите файлы в папку, прописанную в путе доступа к вспомогательным файлам (Сервис->Настройка->Файлы->Путь доступа к вспомогательным файлам) 2. командой _menuload подгрузить файл pltools.mnu, активизировать панель pltools

[CB]

>VVA Я пока не знаю как "скрестить" стандартную команду рисования полилинии, возможность добавления некоторого количеста вершин и затем опять продолжения рисования полилинии ? >MIP Мое мнение всунуть эту возможность в именно в стандартную команду отрисовки полилинии не получется

Собственно это решается (использование стандартной команды "_pline") с помощью простейшей конструкции

Код:

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

 
(command "_pline")
(apply 'command lst)

А язык LISP позволяет создать практически любые списки...
Пример ниже показывает, что это возможно. Акцентирую внимание - это пример, а не готовая функция, т.к. в нем пока не решен вопрос, какую часть полилинии брать если точка выбрана в пересечении сегментов полилинии, ну и не стал заморачиваться с выбором первой точки - новая полилиния строиться от начала и до точки указанной пользователем с продолжением рисования...

Код:

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

(defun c:test (/ test test1 sys_var pl lst)
  (defun test1 (str)
    (if str
      (cons (car str) (test1 (cdr str)))
      (test (cdr lst) "_a")
    ) ;_ end of if
  ) ;_ end of defun
  (defun test (lst l-or-a)
    (cond
      ((null lst) nil)
      ((listp (car lst))
       (cons (car lst) (test (cdr lst) l-or-a))
      )
      ((and (= (car lst) 0.0) (= l-or-a "_l"))
       (test (cdr lst) l-or-a)
      )
      ((and (= (car lst) 0.0) (/= l-or-a "_l"))
       (cons "_l" (test (cdr lst) "_l"))
      )
      ((and (/= (car lst) 0.0) (= l-or-a "_l"))
       (cons "_a"
      (test1 (list "_a" (/ (* 180 4.0 (atan (car lst))) pi)))
       ) ;_ end of cons
      )
      (t (test1 (list "_a" (/ (* 180 4.0 (atan (car lst))) pi))))
    ) ;_ end of cond
  ) ;_ end of defun
  (setq sys_var (mapcar 'getvar '("cmdecho" "cecolor")))
  (setvar 'cmdecho 0)
  (setvar 'cecolor "1")
  (setq pl (car (entsel "\nВыберите pline: ")))
  (if (and pl
    (setq pl (vlax-ename->vla-object pl))
    (= (vla-get-ObjectName pl) "AcDbPolyline")
      ) ;_ end of and
    (vl-catch-all-apply
      (function
 (lambda ()
   (command "_pline")
   (apply 'command
   (test
     ((lambda (p)
        (repeat (+ 2 (fix p))
   (setq lst
          (cons
     (list
       (vlax-curve-getpointatparam pl p)
       (cond
         ((equal (type p) 'REAL)
          (setq temp
          ((lambda (x)
      (/ (sin x) (cos x))
           ) ;_ end of lambda
            (* (rem p 1)
        (atan (vla-getbulge
         pl
         (fix p)
       ) ;_ end of vla-getbulge
        ) ;_ end of atan
            ) ;_ end of *
          )
          ) ;_ end of setq
          0.0
         )
         ((and temp
        (not (equal (vla-getbulge pl p) 0.0))
          ) ;_ end of and
          ((lambda (x) (setq temp nil) x) temp)
         )
         (t (setq temp nil) (vla-getbulge pl p))
       ) ;_ end of cond
     ) ;_ end of list
     lst
          ) ;_ end of cons
   ) ;_ end of setq
   (if (equal (type p) 'REAL)
     (setq p (fix p))
     (setq p (1- p))
   ) ;_ end of if
        ) ;_ end of repeat
        (setq lst (vl-remove nil (apply 'append lst)))
      ) ;_ end of lambda
       (vlax-curve-getparamatpoint
         pl
         (getpoint "\nТочка на полилинии: ")
       ) ;_ end of vlax-curve-getparamatpoint
     )
     "_l"
   ) ;_ end of test
   ) ;_ end of apply
 ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
    (princ
      "\nВыбранный объект не полилиния или не выбран вообще..."
    ) ;_ end of princ
  ) ;_ end of if
  (mapcar 'setvar '("cmdecho" "cecolor") sys_var)
  (princ)
) ;_ end of defun

[CB]

Решил внести в PLTOOLS и свой вклад...
Прошу потестировать программу, сделанную по мотивам #162 :

Код:

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

(defun c:test (/ test sys_var pl)
  (defun test (lst l-or-a temp)
    (cond
      ((null lst) nil)
      (temp
       (if (equal (car temp) "")
  (test lst l-or-a (cdr temp))
  (cons (car temp) (test lst l-or-a (cdr temp)))
       ) ;_ end of if
      ) ;_ end of temp
      ((null (caddr lst))
       (if (equal l-or-a "_l")
  (list (car lst))
  (list (car lst) "_l")
       ) ;_ end of if
      )
      ((equal (cadr lst) 0.0)
       (if (equal l-or-a "_a")
  (test (cddr lst) "_l" (list (car lst) "_l"))
  (cons (car lst) (test (cddr lst) l-or-a temp))
       ) ;_ end of if
      )
      (t
       (test
  (cddr lst)
  "_a"
  (list
    (car lst)
    (if (equal l-or-a "_a")
      ""
      "_a"
    ) ;_ end of if
    "_s"
    (trans
      (vlax-curve-getpointatparam
        pl
        (/
   (+ (vlax-curve-getparamatpoint
        pl
        (trans (caddr lst) 1 0)
      ) ;_ end of vlax-curve-getparamatpoint
      (vlax-curve-getparamatpoint pl (trans (car lst) 1 0))
   ) ;_ end of -
   2.
        ) ;_ end of /
      ) ;_ end of vlax-curve-getpointatparam
      0
      1
    ) ;_ end of trans
  ) ;_ end of list
       ) ;_ end of test
      ) ;_ end of t
    ) ;_ end of cond
  ) ;_ end of defun
  (setq sys_var (mapcar 'getvar '("cmdecho" "cecolor")))
  (setvar 'cmdecho 0)
  (setvar 'cecolor "1")
  (setq pl (car (entsel "\nВыберите pline: ")))
  (if (and pl
    (setq pl (vlax-ename->vla-object pl))
    (= (vla-get-ObjectName pl) "AcDbPolyline")
      ) ;_ end of and
    (vl-catch-all-apply
      (function
 (lambda ()
   (vl-cmdf "_pline")
   (apply 'vl-cmdf
   (test
     (apply
       '(lambda (p1 p2)
   ((lambda (lst)
      (if (apply '< (list p1 p2))
        lst
        (mapcar '(lambda (y)
     (if (numberp y)
       (- y)
       y
     ) ;_ end of if
          ) ;_ end of lambda
         ((lambda (x)
     (cdr (reverse x))
          ) ;_ end of lambda
           lst
         )
        ) ;_ end of mapcar
      ) ;_ end of if
    ) ;_ end of lambda
     ((lambda (param act n / lst)
        (while (<= n param)
          (setq lst
          (append
     lst
     (cons (trans
      (vlax-curve-getpointatparam
        pl
        (if ((eval act) n param)
          param
          n
        ) ;_ end of if
      ) ;_ end of vlax-curve-getpointatparam
      0
      1
           ) ;_ end of trans
           (list (vla-getbulge pl n))
     ) ;_ end of cons
          ) ;_ end of append
          ) ;_ end of setq
          (setq param (max p1 p2)
         act   '>=
          ) ;_ end of setq
          (if (and (equal n (fix param))
     (not (equal n param))
       ) ;_ end of and
     (setq n param)
     (setq n (1+ n))
          ) ;_ end of if
        ) ;_ end of while
        lst
      ) ;_ end of lambda
       (min p1 p2)
       '<
       (fix (min p1 p2))
     )
   )
        ) ;_ end of lambda
       (mapcar
         '(lambda (x / pt p)
     (setq pt (trans (getpoint x) 1 0))
     (while (not (setq p
          (vlax-curve-getparamatpoint
            pl
            pt
          ) ;_ end of vlax-curve-getparamatpoint
          ) ;_ end of setq
     ) ;_ end of not
       (setq pt
       (trans
         (getpoint
           "\rТочка не на полилинии. Повторите выбор: "
         ) ;_ end of getpoint
         1
         0
       ) ;_ end of trans
       ) ;_ end of setq
     ) ;_ end of while
     p
   ) ;_ end of lambda
         (list
    "\nПервая точка на полилинии: "
    "\nВторая точка на полилинии: "
         ) ;_ end of list
       ) ;_ end of mapcar
     ) ;_ end of apply
     "_l"
     nil
   ) ;_ end of test
   ) ;_ end of apply
 ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
    (princ
      "\nВыбранный объект не полилиния или не выбран вообще..."
    ) ;_ end of princ
  ) ;_ end of if
  (mapcar 'setvar '("cmdecho" "cecolor") sys_var)
  (princ)
) ;_ end of defun

PS: Наверняка надо что-то делать с толщиной создаваемой полилинии, т.е. чтобы она повторяла толщины исходной...

[VVA]

Это мой тестовый чертеж для pltools. Прислал в свое время KAI. Ругается на синюю полилинию, что точка не на ней.

[CB]

>VVA
Исправлено в #171 - забыл про trans...

[Cfytrr]

сегодня заметил что в 2009 Акаде x64 не работают команды:
PL-VxAdd, ConvTo3d,
пишет:
; warning: unwind skipped on unknown exception.
Остальные команды вроде работают... На 32 битной версии все работает нормально

[VVA]

К сожалению пока не на чем проверить, но возьму на заметку.

[KAI]

>> VVA
А помнится, кто-то обещал "намедни" выложить обновленный pltools с исправленными багами и дополнениями?
Переписку напомнить?
Народ ждет давно. Это семейство программ им очень нравится.
p.s. А командировки только в Москву? А в Магадан? Готов поделиться комнатой и даже сдать в аренду Мурзика (для сугрева и сняния напряжения).

[Red Nova]

Про PL-VxAdd
Единственное что мне в этой команде раньше казалось неправильным было то что привязка во время работы команды отключалась, по моему это создает лишнее неудобство, но со временем, освоив азы лиспа, я это у себя подправил, поменяв в коде строку с osmode на ("osmode" 16383), чего всем и рекомендую, в таком случае будут включены все привязки. Ну или можно вообще не трогать привязки, и удалить соответствующие строки из кода. Хотелось бы чтобы код изначально был таким.

[Sleekka]

2VVA
Посмотри пожалуйста в команде PL-VxAdd - какая-то ошибка bad argument type: listp #<variant 8197 ...>
2) а нельзя ли добавить в команде PL-Div обработчик ошибок, а то привязки при отмене по Esc не восстанавливаются.

[VVA]

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

[Sleekka]

А не извиняюсь - это я чего-то накосячил =) пятницца

[Supermax]

VVA, а вот скажи, 3D полилинию в сплайн переделывать надо? В смысле с радиусами в вершинах? Я тут сплайны расковырял и в принципе уже могу и дуги и прямолинейные участки делать через entmake сплайнами. Погрешность очень не велика и ее можно сокращать увеличением количества точек на дугах. Вот сижу и ломаю голову, надо это, или не надо.

[Sleekka]

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

[VVA]

Supermax, Это у народа нужно спрашивать. Но раз ты расковырял сплайн, то может будет интересна еще и задача апроксимации сплайна полилинией с дуговыми сегментами.
Sleekka, Да, сплайн "тяжелый" для Автокада примитив.

[Cfytrr]

Извиняюсь, но можно ли подправить работу в AutoCad 2009 64х(описанние в #174)

[VVA]

Cfytrr, Скоро на работе поставят поставят Висту 64 для ананализа работоспособности наших программ по ней. Тогда посмотрю в чем там дело.

[Supermax]

VVA, перевести сплайн в 3D полилинию можно, поскольку имея представление как строится сплайн Автокадом, можно высчитать ряд точек и провести но ним 3D полилинию, но вот имея ряд точек, определить нужна ли там дуга или нет? - Так можно на каждые три точки, которые не лежат на одной прямой дуги лепить.
Короче, с дугами затык.
Потом, сплайн очень коварная штука. В любой момент может выскочить "холмик", который можно описать только очень большим количеством точек, а все остальное может быть просто прямой.

Но, мне кажеться, я где-то уже видел такую прогу.

[Денис Флюстиков]

VVA,

Программа получения полилиний с дуговыми сегментами при выборе сплайнов или эллипсов. Правда, особо не гонял.

[VVA]

Денис Флюстиков, Спасибо, посмотрю.

[Денис Флюстиков]

VVA,
Тестирование программы из поста #187, показало, что для более корректной работы необходимо заменить строчку:
z6 (sin (- (angle (nth (1- z3) z2)(nth z3 z2))
на:
z6 (sin (- (angle (nth (cadr z4) z2)(nth z3 z2))

[Neznayka]

Сложный прямоугольник
Может это под автокад возможно заточить:
« При создании объекта способом "Сложный прямоугольник" вначале вводятся две точки - самая длинная боковая сторона создаваемого объекта, а затем - остальные вершины прямоугольника (через одну). Точки указываются на экране курсором и вводятся нажатием левой кнопки мыши. Промежуточные точки создаются автоматически на пересечении прямой, параллельной первой линии (и проходящей через текущую точку) и перпендикуляра к первой линии, проходящего через предыдущую точку. Таким образом, перпендикулярность всех граней создаваемого объекта (в том числе и последней, замыкающей) отслеживается автоматически.»
Я так и не понял, как замыкать этот прямоугольник, вероятно после клика №4 должен следовать правый клик, который задаёт удаление грани «А» от первоначальной грани

[VVA]

Neznayka,

вероятно после клика №4 должен следовать правый клик, который задаёт удаление грани «А» от первоначальной грани

По мне так не хватает точки 5 на перечении линии А и перпендикуляра к 1. Можно сделать как в команде Облако (_revcloud)ю Там команда завершается, кодга мышкой придешь в исходную точку. А здесь отслеживать , что при указании точки (в данном случае 5) перпендикуляр от нее попадает в точку 1 с некоторым допуском.

[Neznayka]

C точкой 5 имхо плохо, т.к точности не будет (ну если только объектное отслеживание включить).
По принципу "облака" то же хорошо, но будет лишний клик (по т.1) и точка 5 будет "плавать", т.е. её привязкой точно не посадишь, ведь точка 5 все равно будет на перпендикуляре к стороне 1-2. Я чётко излагаю или надо детальный чертеж в районе т.5.
Надо реализовать вариант незамкнутости, и что делать с методом т.5 если надо чтоб продолжить полилинию за грань 1-5, т.е полигон будет с самопересечением (это для тех кто не только домики рисует)
И самый главный вопрос: ВОЗЬМЁТЕСЬ за это?

[zamtmn]

Хороший набор команд. но ENTREVS теряет расширенные данные полилинии, это сложно поправить?

[VVA]

zamtmn, Уже исправил. Постараюсь на днях выложить новую версию.
Neznayka, Буду думать

[VVA]

Neznayka, В качестве первого приближения

Код:

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

;_Dificult RECtangle
(defun C:DREC ( / *error* ss BasePt1 BasePt2 tmp  ang0 ang90 CurrentPt LastPt U_M usr_list eLast)
  (vl-load-com)
  (defun *error* (msg / )
    (while (> (getvar "CMDACTIVE") 0)(command))
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
    (princ msg)
    (if elast
    (progn
      (setq ss nil ss (ssadd))
      (while (setq eLast (entnext eLast)) (ssadd eLast ss))
      (if (= (sslength ss) 0);_ Пустой набор
	(setq ss nil)
	)
      )
    )
  (if ss (command "_.ERASE" ss ""))
     (vla-EndUndoMark
      (vla-get-activedocument (vlax-get-acad-object))
    )
    (princ)
    )
  (setq usr_list (mapcar '(lambda (x) (cons x (getvar x)))
    '("USERR1"  "USERR2"))
  )
    (vla-StartUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  )
  ;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL"))
  (cond
    ((= (logand U_M 1) 0) ;_ Отключено UNDO
     (command "_.UNDO" "_All")
     )
    ((= (logand U_M 3) 3) ;_ Разрешена отмена одной операции
     (command "_.UNDO" "_Control" "_All") 
     )
    (t nil)
  ) ;_ end of cond
    (setq U_M 0) ;_VVA Устанавливаем счетчик отмен UNDO
  ;;; Запоминаем в eLast последний примитив 
    (if (null (setq eLast (entlast)))
      (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
      (setq eLast (entlast))
      (entdel eLast)
      )
    )

  (initget 1)(setq BasePt1 (getpoint "\nПервая базовая точка: "))
  (initget 1)(setq BasePt2 (getpoint BasePt1 "\nВторая базовая точка: "))
  (setq ang0 (angle BasePt1 BasePt2))
  (setq ang90 (+ ang0 (* 0.5 PI)))
  (setq LastPt BasePt2)
  (command "_LINE" "_non" BasePt1 "_non" BasePt2 "")
  (initget "Отмени Undo Замкни Close _Undo Undo Close Close")
  (while (and (setq CurrentPt (getpoint "\nВершина прямоугольника [Отмени/Замкни] <замкни>: "))
	      (setq CurrentPt (if (= CurrentPt "Close") nil CurrentPt))
	      )
    (cond ((listp CurrentPt)
    (setq tmp (inters CurrentPt
		      (polar CurrentPt ang0 100)
		      LastPt
		      (polar LastPt ang90 100)
		      nil
		      )
	  )
    (if tmp
      (progn
        (setvar "USERR1" (car LastPt)) ;_Запоминаем X точки
        (setvar "USERR2" (cadr LastPt));_Запоминаем Y точки
        (command "_.UNDO" "_M") ;_Ставим метку UNDO 
	(command "_LINE" "_non" LastPt "_non" tmp "_non" CurrentPt "")
	(setq LastPt CurrentPt)
	(setq U_M (1+ U_M))
	)
      )
    )
((= CurrentPt "Undo")
      (if (> U_M 0) ;_ Если есть что отменять 
        (progn
   (command "_.UNDO" "_B")
   (setq U_M (1- U_M))
   (setq LastPt (list (getvar "USERR1") (getvar "USERR2")))
   (setvar "LASTPOINT" LastPt)
        )
        (alert "Отменять больше нечего")
      )
     )
	   )
    (initget "Отмени Undo Замкни Close _Undo Undo Close Close")
    )
  (initget 1)(setq CurrentPt (getpoint "\nТочка удаления замыкающей грани: "))
  (if (and
	(setq tmp (inters CurrentPt
		      (polar CurrentPt ang0 100)
		      LastPt
		      (polar LastPt ang90 100)
		      nil
		      )
	  )
	(setq CurrentPt tmp)
	(setq tmp (inters CurrentPt
		      (polar CurrentPt ang0 100)
		      BasePt1
		      (polar BasePt1 ang90 100)
		      nil
		      )
	  )
	)
    (progn
      	(command "_LINE" "_non" LastPt "_non" CurrentPt "")
      	(command "_LINE" "_non"  CurrentPt  "_non" tmp "")
      	(command "_LINE" "_non"  tmp  "_non" BasePt1 "")
      )
    )
  (if elast
    (progn
      (setq ss nil ss (ssadd))
      (while (setq eLast (entnext eLast)) (ssadd eLast ss))
      (if (= (sslength ss) 0);_ Пустой набор
	(setq ss nil)
	)
      )
    )
  (if ss
    (progn
      (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
	(command "_pedit" "_Multiple" ss "" "_Join" 0 "")
	(command "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
	)
      (setq ss nil)
      )
    )
  (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
  (vla-EndUndoMark
      (vla-get-activedocument (vlax-get-acad-object))
    )
  (princ)
 )

[Neznayka]

Ура!!! Вот счастье-то какое.
Пока оттестировать досконально нечем, серьёзных замечаний я не вижу, так только по мелочи:

1. Нажатие на esc во время выполнения команды УДАЛЯЕТ ВСЕ ранее созданное. А не прерывает команду.
2. Очень желательно чтоб во время отрисовки перекрестье было временно повернуто согласно грани 1-2.
3. Не помешало бы видеть саму полилинию во время создания «колена», а не наблюдать её появления как свершившийся факт после клика.
4. Почему Вы решили, что замыкание по нажатию на пробел более удобно чем просто правый клик, если потому что реализовать программно правый клик труднее, то у меня вопросов нет. Впрочем правый клик это на любителя

[VVA]

Сообщение от Neznayka Ура!!! Вот счастье-то какое. Пока оттестировать досконально нечем, серьёзных замечаний я не вижу, так только по мелочи: 1. Нажатие на esc во время выполнения команды УДАЛЯЕТ ВСЕ ранее созданное. А не прерывает команду. Да, так было и задумано, но можно передумать. Надо? 2. Очень желательно чтоб во время отрисовки перекрестье было временно повернуто согласно грани 1-2. Это можно попробывать 3. Не помешало бы видеть саму полилинию во время создания «колена», а не наблюдать её появления как свершившийся факт после клика. Это сложнее. Не обещаю. 4. Почему Вы решили, что замыкание по нажатию на пробел более удобно чем просто правый клик, если потому что реализовать программно правый клик труднее, то у меня вопросов нет. Впрочем правый клик это на любителя

"Дерусь, потому что просто дерусь" © Портос. Я решил что так удобнее. Но можно передумать. Надо?
Кстати правый клик тоже обрабатыватся. И что делать тогда по нажатию на пробел.

[Neznayka]

ЕСЛИ ЭТО НЕ трудозатратно, то, пожалуйста. На пробел - завершение команды на том, где мы остановились и запуск команды по-новому.

[VVA]

Вариант 2

Код:

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

 ;_Dificult RECtangle
(defun C:DREC (/	*error*	 ss	  BasePt1  BasePt2  tmp
	       ang0	ang90	 CurrentPt	   LastPt   U_M
	       usr_list	eLast
	      )
  (vl-load-com)
  (defun *error* (msg /)
    (while (> (getvar "CMDACTIVE") 0) (command))
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
    (princ msg)
    (if	elast
      (progn
	(setq ss nil
	      ss (ssadd)
	) ;_ end of setq
	(while (setq eLast (entnext eLast)) (ssadd eLast ss))
	(if (= (sslength ss) 0) ;_ Пустой набор
	  (setq ss nil)
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
;;;  (if ss (command "_.ERASE" ss ""))
    (if	(and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
      (command "_pedit" "_Multiple" ss "" "_Join" 0 "")
      (command "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
    ) ;_ end of if
    (setq ss nil)
    (vla-EndUndoMark
      (vla-get-activedocument (vlax-get-acad-object))
    ) ;_ end of vla-EndUndoMark
    (princ)
  ) ;_ end of defun
  (setq	usr_list (mapcar '(lambda (x) (cons x (getvar x)))
			 '("USERR1" "USERR2")
		 ) ;_ end of mapcar
  ) ;_ end of setq
  (vla-StartUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL"))
  (cond
    ((= (logand U_M 1) 0) ;_ Отключено UNDO
     (command "_.UNDO" "_All")
    )
    ((= (logand U_M 3) 3) ;_ Разрешена отмена одной операции
     (command "_.UNDO" "_Control" "_All")
    )
    (t nil)
  ) ;_ end of cond
;;; Запоминаем в eLast последний примитив 
  (if (null (setq eLast (entlast)))
    (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
	   (setq eLast (entlast))
	   (entdel eLast)
    ) ;_ end of progn
  ) ;_ end of if
  (while
    (and (setq U_M 0) ;_VVA Устанавливаем счетчик отмен UNDO
	 (setq BasePt1 (getpoint "\nПервая базовая точка <выход>: "))
    ) ;_ end of and
     (initget 1)
     (setq BasePt2 (getpoint BasePt1 "\nВторая базовая точка: "))
     (setq ang0 (angle BasePt1 BasePt2))
     (setq ang90 (+ ang0 (* 0.5 PI)))
     (setq LastPt BasePt2)
     (command "_LINE" "_non" BasePt1 "_non" BasePt2 "")
     (initget "Отмени Undo Замкни Close _Undo Undo Close Close")
     (while (and (setq CurrentPt
			(getpoint
			  "\nВершина прямоугольника [Отмени/Замкни] <выход>: "
			) ;_ end of getpoint
		 ) ;_ end of setq
		 (/= CurrentPt "Close")
	    ) ;_ end of and
       (cond
	 ((listp CurrentPt)
	  (setq	tmp (inters CurrentPt
			    (polar CurrentPt ang0 100)
			    LastPt
			    (polar LastPt ang90 100)
			    nil
		    ) ;_ end of inters
	  ) ;_ end of setq
	  (if tmp
	    (progn
	      (setvar "USERR1" (car LastPt)) ;_Запоминаем X точки
	      (setvar "USERR2" (cadr LastPt)) ;_Запоминаем Y точки
	      (command "_.UNDO" "_M") ;_Ставим метку UNDO 
	      (command "_LINE"	 "_non"	   LastPt    "_non"
		       tmp	 "_non"	   CurrentPt ""
		      ) ;_ end of command
	      (setq LastPt CurrentPt)
	      (setq U_M (1+ U_M))
	    ) ;_ end of progn
	  ) ;_ end of if
	 )
	 ((= CurrentPt "Undo")
	  (if (> U_M 0) ;_ Если есть что отменять 
	    (progn
	      (command "_.UNDO" "_B")
	      (setq U_M (1- U_M))
	      (setq LastPt (list (getvar "USERR1") (getvar "USERR2")))
	      (setvar "LASTPOINT" LastPt)
	    ) ;_ end of progn
	    (alert "Отменять больше нечего")
	  ) ;_ end of if
	 )
       ) ;_ end of cond
       (initget "Отмени Undo Замкни Close _Undo Undo Close Close")
     ) ;_ end of while
     (if (= CurrentPt "Close")
       (progn
	 (initget 1)
	 (setq
	   CurrentPt (getpoint "\nТочка удаления замыкающей грани: ")
	 ) ;_ end of setq
	 (if (and
	       (setq tmp (inters CurrentPt
				 (polar CurrentPt ang0 100)
				 LastPt
				 (polar LastPt ang90 100)
				 nil
			 ) ;_ end of inters
	       ) ;_ end of setq
	       (setq CurrentPt tmp)
	       (setq tmp (inters CurrentPt
				 (polar CurrentPt ang0 100)
				 BasePt1
				 (polar BasePt1 ang90 100)
				 nil
			 ) ;_ end of inters
	       ) ;_ end of setq
	     ) ;_ end of and
	   (progn
	     (command "_LINE" "_non" LastPt "_non" CurrentPt "")
	     (command "_LINE" "_non" CurrentPt "_non" tmp "")
	     (command "_LINE" "_non" tmp "_non" BasePt1 "")
	   ) ;_ end of progn
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
     (setq ss nil)
     (if elast
       (progn
	 (setq ss nil
	       ss (ssadd)
	 ) ;_ end of setq
	 (while (setq eLast (entnext eLast)) (ssadd eLast ss))
	 (if (= (sslength ss) 0) ;_ Пустой набор
	   (setq ss nil)
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
     (if ss
       (progn
	 (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
	   (command "_pedit" "_Multiple" ss "" "_Join" 0 "")
	   (command "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
	 ) ;_ end of if
	 (setq ss nil)
       ) ;_ end of progn
     ) ;_ end of if
     (setq eLast (entlast))
  ) ;_ end of while
  (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
  (vla-EndUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

[Neznayka]

стало хуже: по правому клику появляется контектное меню и в нём надо выбрать ЗАМКНИ, тогда только можно замкнуть прямоугольник.Необходимо блокировать контекстное меню и правый клик должен сразу активировать ЗАМКНИ

[VVA]

Neznayka, Тогда не будет опции Отмени.

[Neznayka]

э-э... т.е ctrl+z, даже и не знаю что лучше, но как во 2 варианте тоже плохо, может ну её (опцию Отмени)

[VVA]

Neznayka, Ctrl+Z будет. Не будет отмены, если не устраивает указанная вершина.

[Neznayka]

ок.

[VVA]

Еще один вариант: замкни пробелу или выбор опции по ПКМ, ESC - выход (на предыдущий уровень).

Код:

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

 ;_Dificult RECtangle
(defun C:DREC (/	*error*	 ss	  BasePt1  BasePt2  tmp
	       ang0	ang90	 CurrentPt	   LastPt   U_M
	       usr_list	eLast Reg
	      )
  (vl-load-com)
  (defun *error* (msg /)
    (while (> (getvar "CMDACTIVE") 0) (command))
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
    (princ msg)
    (if	elast
      (progn
	(setq ss nil
	      ss (ssadd)
	) ;_ end of setq
	(while (setq eLast (entnext eLast)) (ssadd eLast ss))
	(if (= (sslength ss) 0) ;_ Пустой набор
	  (setq ss nil)
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
;;;  (if ss (command "_.ERASE" ss ""))
    (if	(and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
      (command "_pedit" "_Multiple" ss "" "_Join" 0 "")
      (command "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
    ) ;_ end of if
    (setq ss nil)
    (vla-EndUndoMark
      (vla-get-activedocument (vlax-get-acad-object))
    ) ;_ end of vla-EndUndoMark
    (princ)
  ) ;_ end of defun
  (setq	usr_list (mapcar '(lambda (x) (cons x (getvar x)))
			 '("USERR1" "USERR2" "CMDECHO")
		 ) ;_ end of mapcar
  ) ;_ end of setq
  (setvar "CMDECHO" 0)
  (vla-StartUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  ) ;_ end of vla-StartUndoMark
;;;Проверяем установки UNDO и устанавливает All control 
  (setq U_M (getvar "UNDOCTL"))
  (cond
    ((= (logand U_M 1) 0) ;_ Отключено UNDO
     (command "_.UNDO" "_All")
    )
    ((= (logand U_M 3) 3) ;_ Разрешена отмена одной операции
     (command "_.UNDO" "_Control" "_All")
    )
    (t nil)
  ) ;_ end of cond
;;; Запоминаем в eLast последний примитив 
  (if (null (setq eLast (entlast)))
    (progn (entmake '((0 . "point") (10 0.0 0.0 0.0)))
	   (setq eLast (entlast))
	   (entdel eLast)
    ) ;_ end of progn
  ) ;_ end of if
  (while
    (and (setq U_M 0) ;_VVA Устанавливаем счетчик отмен UNDO
	 (setq BasePt1 (getpoint "\nПервая базовая точка <выход>: "))
    ) ;_ end of and
     (initget 1)
     (setq BasePt2 (getpoint BasePt1 "\nВторая базовая точка: "))
     (setq ang0 (angle BasePt1 BasePt2))
     (setq ang90 (+ ang0 (* 0.5 PI)))
     (setq LastPt BasePt2)
     (command "_LINE" "_non" BasePt1 "_non" BasePt2 "")
     (initget "Отмени Undo Замкни Close Дуга Arc Произвольно Free _Undo Undo Close Close Arc Arc Free Free")
     (vl-catch-all-apply
       '(lambda	()
	  (while (and (setq CurrentPt
			     (getpoint
			       "\nВершина прямоугольника (Esc - выход) [Отмени/Дуга/Произвольно/Замкни] <замкни>: "
			     ) ;_ end of getpoint
		      ) ;_ end of setq
		      (/= CurrentPt "Close")
		 ) ;_ end of and
	    (cond
	      ((listp CurrentPt)
	       (setq tmp (inters CurrentPt
				 (polar CurrentPt ang0 100)
				 LastPt
				 (polar LastPt ang90 100)
				 nil
			 ) ;_ end of inters
	       ) ;_ end of setq
	       (if tmp
		 (progn
		   (setvar "USERR1" (car LastPt)) ;_Запоминаем X точки
		   (setvar "USERR2" (cadr LastPt)) ;_Запоминаем Y точки
		   (command "_.UNDO" "_M") ;_Ставим метку UNDO 
		   (command "_LINE"   "_non"	LastPt	  "_non"
			    tmp	      "_non"	CurrentPt ""
			   ) ;_ end of command
		   (setq LastPt CurrentPt)
		   (setq U_M (1+ U_M))
		 ) ;_ end of progn
	       ) ;_ end of if
	      )
	      ((= CurrentPt "Arc")
	        (setvar "USERR1" (car LastPt)) ;_Запоминаем X точки
	        (setvar "USERR2" (cadr LastPt)) ;_Запоминаем Y точки
	        (command "_.UNDO" "_M") ;_Ставим метку UNDO
	        (setvar "CMDECHO" 1)
	        (command "_ARC" "_non" LastPt)
	        (while (> (getvar "CMDACTIVE") 0) (command pause))
	        (setvar "CMDECHO" 0)
	        (setq LastPt (getvar "LASTPOINT"))
	        (setq U_M (1+ U_M))
	       )
	      ((= CurrentPt "Free")
	        (setvar "USERR1" (car LastPt)) ;_Запоминаем X точки
	        (setvar "USERR2" (cadr LastPt)) ;_Запоминаем Y точки
	        (command "_.UNDO" "_M") ;_Ставим метку UNDO
	        (setvar "CMDECHO" 1)
	        (command "_Line" "_non" LastPt)
	        (while (> (getvar "CMDACTIVE") 0) (command pause))
	        (setvar "CMDECHO" 0)
	        (setq LastPt (getvar "LASTPOINT"))
	        (setq U_M (1+ U_M))
	       )
	      ((= CurrentPt "Undo")
	       (if (> U_M 0) ;_ Если есть что отменять 
		 (progn
		   (command "_.UNDO" "_B")
		   (setq U_M (1- U_M))
		   (setq
		     LastPt (list (getvar "USERR1") (getvar "USERR2"))
		   ) ;_ end of setq
		   (setvar "LASTPOINT" LastPt)
		 ) ;_ end of progn
		 (alert "Отменять больше нечего")
	       ) ;_ end of if
	      )
	    ) ;_ end of cond
           (initget "Отмени Undo Замкни Close Дуга Arc Произвольно Free _Undo Undo Close Close Arc Arc Free Free")
	  ) ;_ end of while
	) ;_ end of lambda
     ) ;_ end of vl-catch-all-apply
     (if (or (null CurrentPt) (= CurrentPt "Close"))
       (progn
	 (initget 1)
	 (setq
	   CurrentPt (getpoint "\nТочка удаления замыкающей грани: ")
	 ) ;_ end of setq
	 (if (and
	       (setq tmp (inters CurrentPt
				 (polar CurrentPt ang0 100)
				 LastPt
				 (polar LastPt ang90 100)
				 nil
			 ) ;_ end of inters
	       ) ;_ end of setq
	       (setq CurrentPt tmp)
	       (setq tmp (inters CurrentPt
				 (polar CurrentPt ang0 100)
				 BasePt1
				 (polar BasePt1 ang90 100)
				 nil
			 ) ;_ end of inters
	       ) ;_ end of setq
	     ) ;_ end of and
	   (progn
	     (command "_LINE" "_non" LastPt "_non" CurrentPt "")
	     (command "_LINE" "_non" CurrentPt "_non" tmp "")
	     (command "_LINE" "_non" tmp "_non" BasePt1 "")
	   ) ;_ end of progn
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
     (setq ss nil)
     (if elast
       (progn
	 (setq ss nil
	       ss (ssadd)
	 ) ;_ end of setq
	 (while (setq eLast (entnext eLast)) (ssadd eLast ss))
	 (if (= (sslength ss) 0) ;_ Пустой набор
	   (setq ss nil)
	 ) ;_ end of if
       ) ;_ end of progn
     ) ;_ end of if
     (if ss
       (progn
	 (if (and (getvar "PEDITACCEPT") (= (getvar "PEDITACCEPT") 1))
	   (command "_pedit" "_Multiple" ss "" "_Join" 0 "")
	   (command "_pedit" "_Multiple" ss "" "_Y" "_Join" 0 "")
	 ) ;_ end of if
	 (setq ss nil)
       ) ;_ end of progn
     ) ;_ end of if
     (setq eLast (entlast))
  ) ;_ end of while
  (mapcar '(lambda (x) (setvar (car x) (cdr x))) usr_list)
  (vla-EndUndoMark
    (vla-get-activedocument (vlax-get-acad-object))
  ) ;_ end of vla-EndUndoMark
  (princ)
) ;_ end of defun

[Neznayka]

Все супер, но тут сейчас коллега вносит предложение…
(я конечно понимаю, что наглость второе счастье
Короче коллега говорит, а нельзя ли сделать, чтоб можно было дуги рисовать и или произвольные (неортогональные линии) рисовать. Типа кликнул правой и выбрал в контекстном меню пункт «дуга», нарисовал её и дальше в прежнем режиме или нажал шифт и рисуй линии под любыми углами , а как отпустил снова автоматом включается нормальная работа лиспа.
p/s по-русски drec это вкус
СПАСИБО!!!

[VVA]

Neznayka, Изменил #205

[Neznayka]

Все. У меня и придраться не к чему.
ОГРОМНОЕ ВАМ СПАСИБО!
p/s помните, я просил лисп для отрисовки прямоугольника по 3 точкам. так этот новый лисп заменяет тот старый, только на пробел придется жать.

добавлю после активного юзанья лиспа:
во-первых (извиняюсь за фразу) я "кипяточком писаю" от drec, но вплыло пару мелких недочетов.
2. в лиспе нужно предусмотреть "реверс" иногда он "колено" не в ту сторону заворачивает, типа нажал клавишу и "колено" перевернулось. Если непонятно о чём я. то могу скриншот выложить.
3. лисп во время отрисовки любит прятать полилинию под растр, неудобно когда не контролируешь что чертишь.
4 иногда (когда еще не понял) создаются полилинии нулевой длинны
еще раз спасибо.

[MeshIN]

VVA, а программы могут быть переделаны под Bricscad???

Начальство купило 20 мест, и без этих команд, как без рук

[VVA]

MeshIN, Все зависит, настколько полно BricsCad поддерживает vla-методы и объектную модель. Пока что я знаю, что именно при использовании VLA-* были проблемы. Хотя в BricsCad V9 заявляют
Быстрое ядро LISP с поддержкой более 450 VLAX функций Но все равно нужно пробовать

[MeshIN]

Сообщение от VVA MeshIN, Все зависит, настколько полно BricsCad поддерживает vla-методы и объектную модель. Пока что я знаю, что именно при использовании VLA-* были проблемы. Хотя в BricsCad V9 заявляют Быстрое ядро LISP с поддержкой более 450 VLAX функций Но все равно нужно пробовать

Я конечно уже пробывал, загружал в Brics V9.2, *.cui файл прочитало нормально, работает реверс полилинии, построение прямоугольника по 3 точкам, остальные функции к сожалению не работают (хотя я может что то и пропустил)

[alex8888]

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

И второе, в версии автокада Lite будут работать эти команды или там табу на лисп-приложения?

[Кулик Алексей aka kpblc]

Первое. См. http://forum.dwg.ru/showthread.php?p=398240#post398240
Второе. Не будет. LISP в AutoCAD LT не поддерживается и поддерживаться не будет.

[Supermax]

VVA, привет! Официяльное обращение.
Нужна функция, которая делает обратное CVPOLY, превращает 2D полилинию в 3D полилинию. И еще нужна функция, добавляющая в 3D полилинию вертикальный участок.
Вот есть на 3D полилинии узел, надо ткнув в него и определив знак "+" или "-" добавить либо со строны конца 3D полилинии, либо со стороны начала еще один узел. Его координаты по X и Y такие же как и у прежнего узла, а по Z строится отрезок заданной длинны.
Если смотреть на план с геоподосновой, то ткнув в узел как-бы ничего не произойдет, просто в этом месте появится вертикальный участок, где два узла окажутся друг над другом.
Данная функция нужна всем, кто прокладываетнаружные сети.

[Кулик Алексей aka kpblc]

Supermax, ты только уточни - а какая-нибудь часть полилинии поднимается / опускается или нет? И если да, то как определять?

[VVA]

Нужна функция, которая делает обратное CVPOLY, превращает 2D полилинию в 3D полилинию.

А это для сего делалось?

ConvTo3d -Преобразование линейных объектов в 3D полилинии

По поводу добавления сегмента Алексей вопрос уже задал

[Supermax]

Ну, дык, я ж написал про "+" и "-"

VVA, так не честно! С утра в первом посте совсем другой список был, а лезть в библиотеку функций мне было лень, понадеялся на соответствие.

Кулик Алексей aka kpblc,

Supermax, ты только уточни - а какая-нибудь часть полилинии поднимается / опускается или нет? И если да, то как определять?

Считаю, что надо тупо прибавлять к существующему значению Z длинну участка. по ходу полилинии. Всегда добавляем узел между выбранным узлом и следующим (+1) и Z определяем суммируя введенное значение длинны со знаком.

[VVA]

Давай так. Есть 3d полилиния с началом в т. 0,0,0 и координатами вершин: (0 0 0) (10 10 10) (30 20 0)
Я указал 2 вершину (10 10 10) и набрал +30. Получаем полилинию с координатами вершин (0 0 0) (10 10 10) (10 10 40) (30 20 0)
Я указал 2 вершину (10 10 10) и набрал -30. Получаем полилинию с координатами вершин: ?

[Кулик Алексей aka kpblc]

VVA, возможны варианты: при вводе хоть "+", хоть "-" можно получить разные значения:
'((0. 0. 0.) (10. 10. 10.) (10. 10. 40.) (30. 20. 0.))
'((0. 0. 0.) (10. 10. 10.) (10. 10. 40.) (30. 20. 30.))
Какой из них будет верным?

[Supermax]

Я указал 2 вершину (10 10 10) и набрал +30. Получаем полилинию с координатами вершин (0 0 0) (10 10 10) (10 10 40) (30 20 0) Я указал 2 вершину (10 10 10) и набрал -30. Получаем полилинию с координатами вершин: ?

(0 0 0) (10 10 10) (10 10 -20) (30 20 0)

Все правильно. Добавляем точку только вперед по ходу полилинии.