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

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

Т.е. говоря русским языком объекты соединяются прямолинейным сегментом.

Аналог команды PEDIT->JOIN, но без указания величины разрыва.

Буду искренне благодарен за помощь )))

[VVA]

Что делать, если первый объет - LW полилиния с дуговыми серментами,
второй- 3d полилиния или отрезок с разными значениями Z?

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

Считаем для простоты что дуговых сегментов нет.
Если объединяются несколько плоских объектов, то создаем 3д полилинию.

[CB]

А как узнать какие точки исходных полилиний соединяются прямолинейным сегментом? (у каждой есть начало и конец)

[Profan]

Для 2-х полилиний.

Код:

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

(defun C:PLJ ( / osm obj1 pt1 ent1 obj2 pt2 ent2 ent3)
(setq osm (getvar "OSMODE"))
(setvar "OSMODE" 1)
(setq obj1 (entsel "\n Выберите 1 полилинию ближе к концу: "))
(if obj1
   (progn
   (setq pt1 (cadr obj1))
   (setq ent1 (car obj1))
   )
)
(setq obj2 (entsel "\n Выберите 2 полилинию ближе к концу: "))
(if obj2
    (progn
    (setq pt2 (cadr obj2))
    (setq ent2 (car obj2))
    )
)
(if (and obj1 obj2)
    (progn
    (command "_pline" pt1 pt2 "")
    (setq ent3 (entlast))
    (command "_pedit" "_m" ent1 ent3 ent2 "" "_j" "" "")
    )
    (princ "\n Объекты не выбраны.")
)
(setvar "OSMODE" osm)
(princ)
)

[VVA]

Пробуй
Объединяются полилинии или отрезки вершинами, ближайшими к точке выбора
Результат - 3d полилиния на слое 1-го указанного объекта
Кривизна и ширина сегментов игнорирруется.
Замкнутые полилинии, объекты на блокированном слое игнорируются.

Код:

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

;;;Объединение полилиний, отрезков
;;;Объединяются полилинии, отрезки вершинами, ближайшими к точке выбора
;;; Результат - 3d полилиния на слое 1-го указанного объекта
;;; Кривизна и ширина сегментов игнорирруются
;;; http://forum.dwg.ru/showthread.php?p=103984#post103984

(Defun C:PLJ (/ e1 vobj *error* crs var lst adoc CL Ret)
  (defun *error* (msg) (vla-endundomark adoc)(if CL (setvar "CLAYER" CL)))
  (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 CL (getvar "CLAYER"))(setq Ret t)
 (setq Ret (mapcar '(lambda (msg / Flg)(setq Flg t)
  (while (and Flg Ret)(setq e1 (entsel (strcat "\nВыберите " msg " полилинию  <выход>: ")))
    (cond ((null e1)(if (= (getvar "ERRNO") 52) (setq Flg nil e1 nil vobj nil Ret nil)
	     (princ " *мимо*")))
	  (t (setq vobj (vlax-ename->vla-object (car e1)))
	   (cond ((null (vlax-write-enabled-p vobj))(alert "На блокированном слое!"))
		 ((wcmatch (cdr (assoc 0 (entget (car e1)))) "*POLYLINE,LINE")
		  (if (vlax-curve-isClosed vobj)(alert "Замкнутая полилиния")(setq Flg nil)))
		 (t (alert "Объект не полилиния, отрезок")))))) ;_while
		      e1) (list "первую" "вторую")))
(if (not (vl-some 'null Ret))(progn
    (setq vobj (mapcar '(lambda(x)(vlax-ename->vla-object (car x))) Ret))
    (setvar "CLAYER" (vla-get-Layer (car vobj)))
    (setq crs (mapcar '(lambda(x)(if (wcmatch (strcase(vla-get-ObjectName x)) "*POLYLINE")
      (PLINE-GET-VERTS x)(list (vlax-get x 'StartPoint)(vlax-get x 'EndPoint)))) Vobj))
(setq crs  (mapcar '(lambda(x)(mapcar '(lambda(y)(if (< (length y) 3)(setq y (list (car Y)(cadr Y) 0.0)) y)) x)) crs))
(setq lst (mapcar '(lambda ( pt vla-ob / par dl )(setq pt (cadr pt) pt (vlax-curve-getclosestpointto vla-ob (trans pt 1 0)))
 (setq par (vlax-curve-getParamAtPoint vla-ob pt))
 (if (< (setq dl (vlax-curve-getDistAtParam vla-ob par))
        (- (vlax-curve-getDistAtParam vla-ob (vlax-curve-getEndParam vla-ob)) dl))
(setq pt (vlax-curve-getStartPoint vla-ob))(setq pt (vlax-curve-getEndPoint vla-ob))) pt) Ret vobj))
(setq crs (mapcar '(lambda (pt ls)(if (not(equal (car ls) pt 1e-6))(setq ls (reverse ls))) ls) lst crs))
(setq lst (append (reverse (car crs))(cadr crs)))(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-Add3DPoly (vla-ObjectIDToObject adoc (vla-get-OwnerID (car vobj))) var)
(initget  "Yes No")(if (= (getkword "\nУдалять объекты? [Yes/No] <No> : ") "Yes")
(mapcar '(lambda (x) (if (vlax-write-enabled-p x)(vla-Erase x))) vobj))))
  (setvar "CLAYER" CL)
  (vla-endundomark adoc)
  (princ)
)
(princ "\nНаберите в командной строке PLJ")

[Jochen]

Рекоммендую PEDIT3D.
Смотри на www.black-cad.de
С приветом
Jochen

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

Хех, ну, отцы, спасибо громадное

[KAI]

2 VVA
Володя, а кто мешает проанализировать Z координаты списка, и если они не отличаются рисовать простую полилинию (а не 3DPoly)? Ведь работать с 3DPoly значительно сложнее.

[KAI]

Отвлекся и забыл дописать.
В дополнение к наследованию слоя следовало бы еще наследовать цвет и тип и вес линии. Да и выбираемые объекты не мешало-бы подсветить.

[VVA]

>KAI Мешает отсутствие толковой постановки задачи. Что поставил - то решил. Вариант с анализом координаты Z, посведкой примитивов, наследованием свойств: Linetype LineWeight Color Layer.
Если Z одинаковая (для LW полилиний Z=Elevation), то создается LW полилиния на уровне=Z выбранных объектов без учета кривизны и ширины сегментов.

Код:

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

;;;Объединение полилиний, отрезков
;;;Объединяются полилинии, отрезки вершинами, ближайшими к точке выбора
;;; Результат - 3d полилиния на слое 1-го указанного объекта
;;; Кривизна и ширина сегментов игнорирруются
;;; http://forum.dwg.ru/showthread.php?p=104231#post104231

(Defun C:PLJ (/ e1 vobj *error* crs var lst adoc CL Ret pl is3D)
  (defun *error* (msg)(princ msg)(vl-cmdf "_.redraw")(vla-endundomark adoc)(if CL (setvar "CLAYER" CL)))
  (defun _vxgrdraw ( ptdraw color / len )(setq len (* 0.03 (getvar "VIEWSIZE")))
    (grvecs (list color (polar ptdraw 3.92699  len)(polar ptdraw 0.785398 len)
    (polar ptdraw 5.49779 len)(polar ptdraw 2.35619 len))))
  (defun pline-get-verts (pline_obj / verts)
    (setq verts	(vlax-get pline_obj 'Coordinates)
	  verts	(cond ((wcmatch	(vlax-get pline_obj 'Objectname) "*dPolyline")(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 CL (getvar "CLAYER"))(setq Ret t)
 (setq Ret (mapcar '(lambda (msg / Flg)(setq Flg t)
  (while (and Flg Ret)(setq e1 (entsel (strcat "\nВыберите " msg " полилинию  <выход>: ")))
    (cond ((null e1)(if (= (getvar "ERRNO") 52) (setq Flg nil e1 nil vobj nil Ret nil)
	     (princ " *мимо*")))
	  (t (setq vobj (vlax-ename->vla-object (car e1)))
	   (cond ((null (vlax-write-enabled-p vobj))(alert "На блокированном слое!"))
		 ((wcmatch (cdr (assoc 0 (entget (car e1)))) "*POLYLINE,LINE")
		  (if (vlax-curve-isClosed vobj)(alert "Замкнутая полилиния")
		    (progn (setq Flg nil)(setq lst (vlax-curve-getclosestpointto vobj (trans (cadr e1) 1 0)))
		      (setq var (vlax-curve-getParamAtPoint vobj lst))
		      (if (< (setq crs (vlax-curve-getDistAtParam vobj var))
        (- (vlax-curve-getDistAtParam vobj (vlax-curve-getEndParam vobj)) crs))
(setq lst (vlax-curve-getStartPoint vobj))(setq lst (vlax-curve-getEndPoint vobj)))
		      (_vxgrdraw (trans lst 0 1) -1))))
		 (t (alert "Объект не полилиния, отрезок")))))) ;_while
(vla-Highlight (vlax-ename->vla-object(car e1)) :vlax-true) e1) (list "первую" "вторую")))
(if (not (vl-some 'null Ret))(progn (setq vobj (mapcar '(lambda(x)(vlax-ename->vla-object (car x))) Ret))
    (mapcar '(lambda(x)(vla-Highlight x :vlax-false)) vobj)
    (setvar "CLAYER" (vla-get-Layer (car vobj)))
    (setq crs (mapcar '(lambda(x)(if (wcmatch (strcase(vla-get-ObjectName x)) "*POLYLINE")
      (PLINE-GET-VERTS x)(list (vlax-get x 'StartPoint)(vlax-get x 'EndPoint)))) Vobj))
(setq crs  (mapcar '(lambda(x lw)(mapcar '(lambda(y)(if (< (length y) 3)(setq y (list (car Y)(cadr Y)(vla-get-elevation lw))) y)) x)) crs vobj))
(setq lst (mapcar '(lambda ( pt vla-ob / par dl )(setq pt (cadr pt) pt (vlax-curve-getclosestpointto vla-ob (trans pt 1 0)))
 (setq par (vlax-curve-getParamAtPoint vla-ob pt))
 (if (< (setq dl (vlax-curve-getDistAtParam vla-ob par))
        (- (vlax-curve-getDistAtParam vla-ob (vlax-curve-getEndParam vla-ob)) dl))
(setq pt (vlax-curve-getStartPoint vla-ob))(setq pt (vlax-curve-getEndPoint vla-ob))) pt) Ret vobj))
(setq crs (mapcar '(lambda (pt ls)(if (not(equal (car ls) pt 1e-6))(setq ls (reverse ls))) ls) lst crs))
(setq lst (append (reverse (car crs))(cadr crs)))
(setq crs (mapcar 'caddr lst))
(setq var (mapcar '(lambda(x)(equal x (car crs) 1e-6)) crs))
(if (vl-some 'null var)
  (setq is3D t)  ;;; 3D
  (setq is3D (car crs);;;LW Уровень
	 lst (mapcar '(lambda(x)(list (car x)(cadr x))) 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)))
(if (numberp is3D)
  (progn
 (setq pl (vla-AddLightWeightPolyline (vla-ObjectIDToObject adoc (vla-get-OwnerID (car vobj))) var))
 (vla-put-elevation pl is3D)
 )
(setq pl (vla-Add3DPoly (vla-ObjectIDToObject adoc (vla-get-OwnerID (car vobj))) var)))
(mapcar '(lambda (x y) (vlax-put-property pl x y)) '(Linetype LineWeight Color Layer)
	   (mapcar '(lambda (x)(vlax-get-property (car vobj)  x))  '(Linetype LineWeight Color Layer)))    
(initget  "Yes No")(if (= (getkword "\nУдалять объекты? [Yes/No] <No> : ") "Yes")
(mapcar '(lambda (x) (if (vlax-write-enabled-p x)(vla-Erase x))) vobj))))
  (setvar "CLAYER" CL)(vl-cmdf "_.redraw")(vla-endundomark adoc)(princ))
(princ "\nНаберите в командной строке PLJ")

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

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

[VVA]

Выкладывай

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

Выкладываю
[ATTACH]1164353073.dwg[/ATTACH]

[VVA]

Дык у меня все нормально объединяет. Делал кодом №11 Autocad 2006 Rus

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

Странно. В приложенном выше файле показан результат работы программы.
У меня Акад 2005 английский.
Может быть какие нибудь личные настройки влияют на работу программы?

[VVA]

Проверил в Acad 2005 Rus. То же работает. Надо найти третьего .
Кто-нибудь проверьте код с поста 11 на файле с поста 14. Нужно соединить 2 полилинии ближайшими концами. :!:

[Profan]

Проверил на AutoCAD 2006 ENG. Программа сработала нормально.
Проверил на AutoCAD 2007 RUS. Программа сработала нормально.

Заодно проверил свою программу. Тоже все в порядке.

Может, действительно, играют роль настройки, сохраняющиеся в реестре, а не в рисунке?

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

>>Profan
У меня твоя программа тоже некорректно работает
Полилиния добавляется не между концами исходных полилиний, а в местах "тыканья" курсором.
Прилагаю файл с результатами работы:
[ATTACH]1164365479.dwg[/ATTACH]

[Profan]

Для Кочетков Андрей.
Вот что я могу сказать. На твоих полилиниях много вершин, причем, на правой две находятся очень близко к разрыву. В моем коде программно установлена привязка к конечной точке, но на экране это не отслеживается. Попробуй зумом приблизить место разрыва и во время выполнения программы явно задать привязку "_end" ("кон") хотя бы с Shift+правая кнопка мыши. Тогда будет видно, куда привязывется прицел. Таким способом можно точно поймать конечные точки полилиний, иначе можно привязаться к другой вершине. Моя программа очень проста, в ней не вычисляются конечные вершины полилиний. Вот программа VVA объединяет полилинии при выборе их и на значительном расстоянии от разрыва.