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

Добрый день!
Нужна помощь программистов )

Мну нужен Лисп, соединяющий концы выделенных объектов.

Объекты - полилинии.

Исходник и результат я показал в приложенных скринах.

Прошу помочь.

[VVA]

Пробуй.
Т.к. ты не указал какие полилинии (LW или 3D), то сделал так:
если полилинии лежат в одном уровне, то должна соединять LW полилинией, если в разных , то 3D

Код:

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

(defun C:EPP ( / pt1 pt2 blst ss i lst lst-pr tmp pl csp)
;;End Point Polyline
;;Построение полилинии, соединяющей концы выделенных объектов
;;http://forum.dwg.ru/showthread.php?t=36412

  (initget 1)
  (setq pt1 (getpoint "\nПервая точка рамки: "))
  (initget 1)
  (setq pt2 (getcorner pt1 "\nВторая точка рамки: "))
  (setq blst (list pt1 (list (car pt1)(cadr pt2)(caddr pt1)) pt2 (list (car pt2)(cadr pt1)(caddr pt1)))
        blst (mapcar '(lambda(x)(list (car x)(cadr x)))blst)
        )
  (if (setq ss (ssget "_C" pt1 pt2 '((0 . "*POLYLINE"))))
    (progn
      (setq lst nil lst-pr nil)
      (repeat (setq i (sslength ss)) ;_ end setq
        (setq pl (ssname ss (setq i (1- i))))
        (cond ((IsPointInside
                 (progn
                   (setq pt1 (vlax-curve-getStartPoint pl))
                   (setq pt2 (mapcar '+ pt1 '(0 0)))
                   )
               blst
               )
               (setq lst-pr (cons pt2 lst))
               (setq lst (cons pt1 lst))
               )
              ((IsPointInside
               (progn
                   (setq pt1 (vlax-curve-getEndPoint pl))
                   (setq pt2 (mapcar '+ pt1 '(0 0)))
                   )
               blst
               )
               (setq lst-pr (cons pt2 lst))
               (setq lst (cons pt1 lst))
               )
              (t nil)
              )
         ) ;_ end repeat
      (setq pt1 (car (GetListBoundingBox lst-pr)))
      (setq tmp
             (vl-sort-i
               lst-pr
               '(lambda(x y)
                  (< (distance pt1 x)(distance pt1 y))))
            )
      (setq lst (mapcar '(lambda(x)(nth x lst)) tmp))
      (setq csp (vla-ObjectIDToObject
                       (vla-get-ActiveDocument (vlax-get-acad-object))
                       (vla-get-OwnerID (vlax-ename->vla-object pl))))
      (if (apply '= (mapcar 'last lst))
        (progn ;_LWPOLYLINE
          (setq pt1 (caddar lst))
          (setq lst (mapcar '(lambda(x)(list (car x)(cadr x))) lst))
          (setq tmp (apply 'append lst))
          (setq tmp (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray
                  vlax-vbDouble (cons 0 (1- (length tmp)))) tmp)))
          (setq tmp (vla-addLightWeightPolyline csp tmp))
          (vla-put-elevation tmp  pt1)
          )
        (progn ;_3DPOLYLINE
          (setq tmp (apply 'append lst))
          (setq tmp (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray
                  vlax-vbDouble (cons 0 (1- (length tmp)))) tmp)))
           (vla-Add3DPoly csp tmp)
         )
        )
      )
    )
  (princ)
  )
(defun IsPointInside (Point Boundary / FarPoint Check)
;_* алгоритм взят на http://algolist.manual.ru/maths/geom/belong/poly2d.php
;_* На основе vk_IsPointInside
;_* Опубликовано  http://www.caduser.ru/forum/index.php?PAGE_NAME=message&FID=23&TID=36191&MID=205580&sessid=79096aca9605acaa6da486d593128e41&order=&FORUM_ID=23
;_                 http://www.arcada.com.ua/forum/viewtopic.php?p=12322
;_* Boundary - список нормализованных [т.е. только либо (X Y) либо (X Y Z)] точек
  
  ;_Проверяет Boundary на условие car и last одна и та же точка
  (if (not (equal (car Boundary)(last Boundary) 1e-6))
    (setq Boundary (append Boundary (list(car Boundary)))))
  (setq FarPoint (cons (+ (apply 'max (mapcar 'car Boundary)) 1.0)
                       (cdr Point)
                 ) ;_ end of cons
  ) ;_ end of setq
  (or
    (not
      (zerop
        (rem
          (length
            (vl-remove
              nil
              (mapcar
                (function (lambda (p1 p2) (inters Point FarPoint p1 p2))
                ) ;_ end of function
                Boundary
                (cdr Boundary)
              ) ;_ end of mapcar
            ) ;_ end of vl-remove
          ) ;_ end of length
          2
        ) ;_ end of rem
      ) ;_ end of zerop
    ) ;_ end of not
    (vl-some (function (lambda (x) x))
             (mapcar
               (function (lambda (p1 p2)
                           (or Check
                               (if (equal (+ (distance Point p1)
                                             (distance Point p2)
                                             ) ;_ end of +
                                          (distance p1 p2)
                                          1e-3) ;_ end of equal
                                 (setq Check T) nil)
                               )
                         ) ;_ end of lambda
               ) ;_ end of function
               Boundary
               (cdr Boundary)

             ) ;_ end of mapcar
    ) ;_ end of vl-some
  ) ;_ end of or
)
(defun GetListBoundingBox (pt_lst)
  (list	(apply 'mapcar (cons 'min pt_lst))
	(apply 'mapcar (cons 'max pt_lst))
  )
)

[Дима_]

Есть еще вариант разминки - соединяет с верху в низ - запускать CLOSELINE:

Код:

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

(vl-load-com)
(defun pln (lst c); создает полилинию по списку вершин lst, c - nil/T - разомкн/замкнт или '(с слой цвет).
(entmakex (append
(list (cons 0 "LWPOLYLINE")(cons 100 "AcDbEntity")(cons 100 "AcDbPolyline") (cons 90 (length lst)))
(if (= (type c) 'list)
(vl-remove nil (list
(if (car c) (cons 70 1) (cons 70 0))
(if (cadr c) (cons 8 (cadr c)))
(if (caddr c) (cons 62 (caddr c)))
));end of list & vl-remove
(list (if c (cons 70 1) (cons 70 0)))
);end of if
(mapcar '(lambda (x) (cons 10 x)) lst)
));end of apend & entmakex
);end of pln

(defun c:closeline ( / pt1 pt2)
(setq	pt1 (getpoint "\nВыделите нужный фрагмент ")
	pt2 (getcorner pt1)
	pt1 (vl-sort (vl-remove nil (mapcar '(lambda (obj / pt ptl)
(setq pt (cdr (assoc 10 (entget obj))) ptl (cdr (assoc 10 (reverse (entget obj)))))
(if (and 
(>= (car pt) (apply 'min (list (car pt1) (car pt2)))) 
(>= (cadr pt) (apply 'min (list (cadr pt1) (cadr pt2)))) 
(<= (car pt) (apply 'max (list (car pt1) (car pt2)))) 
(<= (cadr pt) (apply 'max (list (cadr pt1) (cadr pt2)))) 
);end of and
pt
(if (and
(>= (car ptl) (apply 'min (list (car pt1) (car pt2)))) 
(>= (cadr ptl) (apply 'min (list (cadr pt1) (cadr pt2)))) 
(<= (car ptl) (apply 'max (list (car pt1) (car pt2)))) 
(<= (cadr ptl) (apply 'max (list (cadr pt1) (cadr pt2)))) 
);end of and
ptl
));end of if*2
);end of lambda
(vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_c" pt1 pt2 (list (cons 0 "lwpolyline") (cons 70 0))))))
));end of mapcar & vl-remove
'(lambda (x1 x2) (> (cadr x1) (cadr x2))));end of vl-sort
);end of setq
(if (and pt1 (> (length pt1) 1))
(pln pt1 nil)
(alert "Выберите 2 и более полилини")
);end of if
(princ)
);end of closeline

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

Володя, Дима, спасибо за программы!

Володя твой код в некоторых случаях соединяет концы не по порядку.

[Дима_]

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