AutoLISP to create enclosed Polylines from parallel Lines

[KevinAlc0r]

Hi all,

 

Are there any LISP routine that can help me to create enclosed polyline from parallel line as shown below:

 

1. First, I have the parallel individual lines as shown below:

 

2. I want to know if any LISP exists that converts both Lines into an enclosed single PolyLine objectas shown below:

 

I tried Lee Mac's Polyline LISP (http://www.lee-mac.com/polylineprograms.html), especially the Polyline Join and Close command, but the only part that works is the Polyline Join command which transform each Line objects into Polylines but the Polyline Close command can't close the polylines together. I guess Lee Mac's LISP was not intended for my case.

 

Any help would be greatly appreciated! Thanks in advance!

[rlx]

I would like to suggest Lee's outline lsp

 

http://www.lee-mac.com/outlineobjects.html

 

 

[BIGAL]

Something similar was asked here 

I redid the code it just uses the object layer for new pline.

https://www.cadtutor.net/forum/topic/72563-autolisp-to-create-enclosed-polylines-from-parallel-lines/

; Join end of 2  lines convert to pline
; By Alan H March  2021


(defun  C:joinends ( / pt1 pt2 start end  swapends)

(defun swapends (pt / temp d1 d2 ent)
(setq ent (entget (ssname (ssget pt)0 )))
(setq lay (cdr (assoc 8 ent)))
(setq end (cdr (assoc 11 ent)))
(setq start (cdr (assoc 10 ent)))
(setq d1 (distance pt end))
(setq d2 (distance pt start))
(if (< d1 d2)
    (progn
       (setq temp end)
       (setq end start)
       (setq start temp)
    )
)
(command "erase" (cdr (assoc -1 ent)) "")
(princ)
)

(setq oldsnap (getvar 'osmode))
(setvar 'osmode 512)
(setq lst '())


(setq pt1 (getpoint "Pick point near end of line 1 "))
(swapends pt1)

(setq lst (cons (list (car start) (cadr start))lst))
(setq lst (cons (list (car end)(cadr end)) lst))

(setq pt2 (getpoint "Pick point near end of line 2 "))
(swapends pt2)

(setq lst (cons (list (car end)(cadr end)) lst))
(setq lst (cons (list (car start) (cadr start))lst))

(setvar 'osmode 0)

(entmakex (append (list (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 8 lay)
          (cons 90 (length lst))
          (cons 70 1))
          (mapcar (function (lambda (p) (cons 10 p))) lst)
           )
)

(setvar 'osmode oldsnap)
(princ)
)

(C:joinends)

[devitg]

Please give it a try 

 

;;************************************************************
(DEFUN BUTLAST  (LST)
    (REVERSE (CDR (REVERSE LST)))
    )

;;************************************************************
;;************************************************************
;;;(setq lista NEW-PT-LIST)
(DEFUN &-2DPOLY/LISTXY  (LISTA / FLAT-LIST MODEL SAF ) ;_01
  ;;*//*/*/*/*/*/*/*/*/*/*/*/*/**/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*/*
  (DEFUN DT:LIST-FLATTEN  (LISTE /)
    (COND
      ((NULL LISTE) NIL)
      ((ATOM LISTE) (LIST LISTE))
      (1
       (APPEND (DT:LIST-FLATTEN (CAR LISTE))
               (DT:LIST-FLATTEN (CDR LISTE))))
      )
    ) ;_ defun  DT:LIST-FLATTEN
  (DEFUN I:POINTS  (PTLIST)
    (VL-LOAD-COM)
    (VLAX-SAFEARRAY-FILL
      (VLAX-MAKE-SAFEARRAY
        VLAX-VBDOUBLE
        (CONS 0 (1- (LENGTH PTLIST)))
        )
      PTLIST
      )
    ) ;_end defun i:Points
  ;;/------------------------------------------------------------------
  (SETQ FLAT-LIST (DT:LIST-FLATTEN LISTA))
  (SETQ SAF (I:POINTS FLAT-LIST))
  (VLA-ADDLIGHTWEIGHTPOLYLINE MODEL SAF)
  ) ;_ &-2dpoly
;;************************************************************




	

(defun c:line-2-poly (/ END-DIST LINE-00 LINE-00-END LINE-00-ST LINE-01 LINE-01-END LINE-01-ST
                      LINE-DIST POLY POLY-PT-LIST SELECT-//-LINES ST-DIST
                       ACAD-OBJ ADOC MODEL
                     )
(VL-LOAD-COM)
  (SETQ ACAD-OBJ (VLAX-GET-ACAD-OBJECT)) ;_ el programa ACAD 
  (SETQ ADOC (VLA-GET-ACTIVEDOCUMENT ACAD-OBJ)) ;_ el DWG que esta abierto-
  (SETQ MODEL (VLA-GET-MODELSPACE ADOC))


  (setq select-//-lines (ssget '((0 . "LINE"))))

  (Setq line-00 (ssname select-//-lines 0))
  (Setq line-01 (ssname select-//-lines 1))

  (setq line-00-st (cdr (assoc 10 (entget line-00))))

  (setq line-01-st (cdr (assoc 10 (entget line-01))))

  (setq line-00-end (cdr (assoc 11 (entget line-00))))

  (setq line-01-end (cdr (assoc 11 (entget line-01))))

  (setq st-dist (distance line-00-st line-01-st))

  (setq end-dist (distance line-00-end line-01-end))
  (setq line-dist (distance line-00-st line-00-end))

  (if (< st-dist line-dist)

    (setq poly-pt-list (mapcar 'butlast (list line-00-st line-00-end line-01-end line-01-st)))

    (setq poly-pt-list (mapcar 'butlast (list line-00-st line-00-end line-01-st line-01-end)))

  ) ;_  if


  (setq poly (&-2DPOLY/LISTXY poly-pt-list))
  (VLA-PUT-CLOSED poly :VLAX-TRUE)
  (entdel line-00)
  (entdel line-01)

) ;_  defun

 

[KevinAlc0r]

Dear @BIGAL

 

Thank you Sir/Madam for the LISP, it works exactly just like what I needed.

Since I am pretty new to AutoLISP, is there a way to automate this LSIP routine/process on multiple parallel lines at the same time?

 

For example if I have multiple parallel lines as shown below:

 

Thank you!

[KevinAlc0r]

Dear @devitg,

 

Thank you Sir for sharing your code with me. I am sorry because I am new to LISP, when I run your command (I believe it is LINE-2-POLY), and picked the two parallel lines I got a VLA-OBJECT nil error. Do you know where I did wrong? Thank you

[KevinAlc0r]

Dear @rlx

 

Thank you for sharing with me, I tried the OUTLINE command from Lee's outline lsp but it didn't work for me, I guess the purpose of the LISP is to obtain the outline of objects that are intertwined together and can't somehow be used in mine

[rlx]

No problem Kevin , that's just me being lazy and hoping it would work (without trying it myself)

[BIGAL]

Yes there is a simple solution I almost did the original code that way. You just pick based on image left side then right side so a selection of all the lines is made, a simple check of the order is carried out ie left to right, then its just pairs and code as posted used. Obvious is 1st check must be equal number of lines. Need a bit of time have to find the routines in other code. For your image will need to run twice.

 

Edited March 24, 2021 by BIGAL

[BIGAL]

version 2

 

; Join end of 2 multiple lines convert to pline
; By Alan H March  2021


(defun  c:joinends ( / pt1 pt2 start end  swapends)

(defun ah:swapends (pt / temp d1 d2 ent)
(setq ent (entget (ssname (ssget pt)0 )))
(setq lay (cdr (assoc 8 ent)))
(setq end (cdr (assoc 11 ent)))
(setq start (cdr (assoc 10 ent)))
(setq d1 (distance pt end))
(setq d2 (distance pt start))
(if (< d1 d2)
    (progn
       (setq temp end)
       (setq end start)
       (setq start temp)
    )
)
(command "erase" (cdr (assoc -1 ent)) "")
(princ)
)

(setq oldsnap (getvar 'osmode))
(prompt "\nPick points eg left and right of lines")
(setq pt1 (getpoint "\Pick 1st point "))
(setq pt2 (getpoint pt1 "\Pick 2nd  point "))

(setq lst (list pt1 pt2))
(setq ss (ssget "F" lst (list (cons 0 "*line"))))
(setq lay (cdr (assoc 8 (entget (ssname ss 0)))))

(setq lst2 '())
(repeat (setq x (sslength ss))
(setq ent (ssname ss (setq x (- x 1))))
(setq obj (vlax-ename->vla-object ent))
(setq pt3 (vlax-curve-getclosestpointto obj pt1))
(setq dist (distance pt1 pt3))
(setq lst2 (cons (list dist pt3) lst2))
)
(setq lst2 (vl-sort lst2 '(lambda (x y) (< (car x)(car y)))))

(setq lst '())
(setq x 0)
(setvar 'osmode 0)
(repeat (/ (sslength ss) 2)
(setq lst '())
(setq pt3 (nth 1 (nth x lst2)))
(ah:swapends pt3)

(setq lst (cons (list (car start) (cadr start))lst))
(setq lst (cons (list (car end)(cadr end)) lst))

(setq pt4 (nth 1 (nth (+ x 1) lst2)))
(ah:swapends pt4)

(setq lst (cons (list (car end)(cadr end)) lst))
(setq lst (cons (list (car start) (cadr start))lst))

(setq x (+ x 2))

(entmakex (append (list (cons 0 "LWPOLYLINE")
          (cons 100 "AcDbEntity")
          (cons 100 "AcDbPolyline")
          (cons 8 lay)
          (cons 90 (length lst))
          (cons 70 1))
          (mapcar (function (lambda (p) (cons 10 p))) lst)
           )
)

)

(setvar 'osmode oldsnap)

(princ)
)

 

[KevinAlc0r]

Big thanks @BIGAL for the second version. I have tried the second version and it works just like the following:

 

 

The lines are also turned into Polylines automatically! Once again, Thanks a lot!

[BIGAL]

To make life easier for you drag line say near end but down a bit make sure you are " outside" both ends look at image. See red dashed line.

 

You dont have to touch outside lines, so long as pt2 drag crosses the lines.

 

Same left right, right left will work same as up down etc. 

 

Oh yeah dont do a cross diagonal will get bowties.

Edited March 25, 2021 by BIGAL

[KevinAlc0r]

You mean by dragging from left to right like this?

 

[Tharwat]

Give this a shot and let me knw.

 

(defun c:Test ( / i s e g p q l r m d)
  ;; Tharwat - Date: 25.Mar.2021	;;
  (and (princ "\nSelect parallel line objects to replace with closed polylines : ")
       (setq i -1 s (ssget "_:L" '((0 . "LINE"))))
       (while (setq i (1+ i) e (ssname s i))
         (setq g (entget e)
               p (cdr (assoc 10 g))
               q (cdr (assoc 11 g))
               l (cons (list (cdr (assoc -1 g)) (mapcar '(lambda (j k) (/ (+ j k) 2.)) p q) p q) l)
               )
         )
       (progn
         (foreach itm l
           (or (vl-position (car itm) d)
               (and (setq m (cadr itm))
                    (setq r (cadr (vl-sort l '(lambda (j k) (< (distance m (cadr j)) (distance m (cadr k)))))))
                    (not (vl-position (car r) d))
                    (setq p (caddr itm))
                    (entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1))
                                     (mapcar (function (lambda (n) (cons 10 n)))
                                             (append (list p)
                                                     (vl-sort (cddr r) '(lambda (j k) (< (distance p j) (distance p k))))
                                                     (list (cadddr itm))
                                                     )
                                             )
                                     )
                             )
                    (setq d (cons (car itm) d)
                          d (cons (car r) d)
                          )
                    )
               )
           )
         (mapcar 'entdel d)
         )
       )
  (princ)
  ) (vl-load-com)
                

 

[ronjonp]

Nice work @Tharwat  FWIW a technique I use on lists like this ( learned from others ) is to check that there are two items still in the list within a while loop then you can remove them as you go so no need to keep a list 'd'  to check against.

(while (cadr l)
  (setq	a (car l)
	l (cdr l)
  )
  ;; Find matching item, do your stuff then
  (setq l (vl-remove item l))
)

 

 

[Tharwat]

Thank you @ronjonp honestly I tried vl-remove at the beginning but that did not behave correctly in some cases and that's why I moved to another technique to work around it and that got the job done as expected.

 

Actually it did not work specifically once the list was like ( <midpoint> <start point> <end point> ) and I thought that the coordinates list was the culprit in preventing the list to be removed from the list of data but this still a guess and not quite confirmed.

[KevinAlc0r]

Wow, marvelous @Tharwat, I tried your LISP and it works wonders! It reduced the amount of time needed to do these repetitive tasks.

 

If I understand it correctly, @ronjonp's code snippet is used as a proper way to remove items from lists inside a loop right?

[eldon]

The end product looks just like a rectangle. Perhaps it should have been drawn as a rectangle in the first place?

[KevinAlc0r]

Hi @eldon, I specifically asked for this LISP because I noticed that multiple drawings of beams or walls are drawn as a pair of parallel lines. However, I am creating a Revit add-in to create walls from 2D CAD drawings and for it to work properly, I need the drawings to be turned into Polylines as quickly as possible. That is why they are not drawn as rectangles in the first place

[ronjonp]

On 3/25/2021 at 11:45 AM, Tharwat said:

Thank you @ronjonp honestly I tried vl-remove at the beginning but that did not behave correctly in some cases and that's why I moved to another technique to work around it and that got the job done as expected.

 

Actually it did not work specifically once the list was like ( <midpoint> <start point> <end point> ) and I thought that the coordinates list was the culprit in preventing the list to be removed from the list of data but this still a guess and not quite confirmed.

 @Tharwat Not heavily tested but this was my train of thought ( removed the vl-remove part ) 

(defun c:test (/ i s e g q l r m d)
  ;; Tharwat - Date: 25.Mar.2021	;;
  ;; RJP - While loop example removing objects as they are processed
  (and (princ "\nSelect parallel line objects to replace with closed polylines : ")
       (setq i -1
	     s (ssget "_:L" '((0 . "LINE")))
       )
       (while (setq i (1+ i)
		    e (ssname s i)
	      )
	 (setq g (entget e)
	       p (cdr (assoc 10 g))
	       q (cdr (assoc 11 g))
	       l (cons (list (cdr (assoc -1 g)) (mapcar '(lambda (j k) (/ (+ j k) 2.)) p q) p q) l)
	 )
       )
       ;; While two items are in the list
       (while (cadr l)
	 ;; Set first item
	 (setq itm (car l))
	 ;; Get midpoint
	 (setq m (cadr itm))
	 ;; Remove first item
	 (setq l (cdr l))
	 ;; Sort closest
	 (setq l (vl-sort l '(lambda (j k) (< (distance m (cadr j)) (distance m (cadr k))))))
	 ;; Set second item
	 (setq itm2 (car l))
	 ;; Remove second item
	 (setq l (cdr l))
	 (entmake
	   (append
	     (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4)
		   '(70 . 1))
	     (mapcar (function (lambda (n) (cons 10 n)))
		     (append (list (caddr itm))
			     (vl-sort (cddr itm2) '(lambda (j k) (< (distance p j) (distance p k))))
			     (list (cadddr itm))
		     )
	     )
	   )
	 )
	 ;; Delete the two lines
	 (foreach e (list itm itm2) (entdel (car e)))
       )
  )
  (princ)
)
(vl-load-com)

 

Edited March 26, 2021 by ronjonp