Author Topic: Join lots of small lines  (Read 9291 times)

0 Members and 1 Guest are viewing this topic.

hudster

  • Gator
  • Posts: 2848
Join lots of small lines
« on: February 02, 2006, 10:30:15 AM »
Does anyone have a lisp which will look for lines which are end to end and on the same layer in a drawing and combine them?

I have an architects drawing made up of lots of very small lines and i'd like to combine them.

Cheers
Revit BDS 2017, 2016, 2015, 2014, AutoCAD 2017, 2016, Navisworks 2017, 2016, BIM360 Glue

David Hall

  • Automatic Duh Generator
  • King Gator
  • Posts: 4075
Re: Join lots of small lines
« Reply #1 on: February 02, 2006, 10:37:21 AM »
overkill?
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second.
Sometimes the question is more important than the answer. (Thanks Kerry for reminding me)

hudster

  • Gator
  • Posts: 2848
Re: Join lots of small lines
« Reply #2 on: February 02, 2006, 10:39:05 AM »
I tried that, doesn't do it for this one.
Revit BDS 2017, 2016, 2015, 2014, AutoCAD 2017, 2016, Navisworks 2017, 2016, BIM360 Glue

M-dub

  • Guest
Re: Join lots of small lines
« Reply #3 on: February 02, 2006, 10:52:47 AM »
I thought I had one, but it might be at my other office...
In the meantime,

http://www.theswamp.org/forum/index.php?topic=6093.0

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #4 on: February 02, 2006, 04:37:56 PM »
Code: [Select]
(defun c:GLUE (/ flist slist f1pt f2pt s1pt s2pt)
  ;;(ARCH:F_S-VAR)
  (setq
    flist (entget (setq flin (car (entsel "\n* Pick first Line *"))))
  )
  (setq
    slist (entget (setq slin (car (entsel "\n* Pick second Line *"))))
  )
  (setq f1pt (cdr (assoc 10 flist)))
  (setq f2pt (cdr (assoc 11 flist)))
  (setq s1pt (cdr (assoc 10 slist)))
  (setq s2pt (cdr (assoc 11 slist)))
  (command "LAYER" "S" (cdr (assoc 8 flist)) "")
  (command "ERASE" flin "")
  (command "ERASE" slin "")
  (setq dis1 (distance f1pt s1pt))
  (setq dis2 (distance f2pt s1pt))
  (setq dis3 (distance f1pt s2pt))
  (setq dis4 (distance f2pt s2pt))
  (setq maxm (max dis1 dis2 dis3 dis4))
  (cond
    ((= dis1 maxm) (command "LINE" f1pt s1pt ""))
    ((= dis2 maxm) (command "LINE" f2pt s1pt ""))
    ((= dis3 maxm) (command "LINE" f1pt s2pt ""))
    ((= dis4 maxm) (command "LINE" f2pt s2pt ""))
    (T nil)
  )
  ;;(ARCH:F_R-VAR)
  (princ)
)
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

hyposmurf

  • Guest
Re: Join lots of small lines
« Reply #5 on: February 03, 2006, 05:18:24 PM »
Heres another:

;
Code: [Select]
; This routine joins two lines, two arcs, two 3dfaces, or two text items
; together. If arcs are selected, they must share a common center point and radius.
;  For lines there is no such restriction. Two lines of different angles can be
; joined. The program loops to allow several pairs of objects to be joined.
;
; When gluing text together, the text value of the second selected text
; item is added on to the first. A space is inserted between text items.
;
;;**********Required Functions*******************
;
;replaces needing to use (cdr (assoc type number) functions
;
(defun dxf ( CODE ELIST / A)
   (SETQ A (CDR (ASSOC CODE ELIST)))
   (IF (NOT A)
      (IF (OR (= CODE 38) (= CODE 39)) (SETQ A 0.0)
      )
   )A
)

;--------------------------------------------------------------
; Function that finds the max point between 2 point lists.
; Used to join 3dfaces. Subsequent calls can pass a test point not to match
;
(defun glue1 (pt1 pt2 dist testpt / n o retpt)
   (foreach n pt1
      (foreach o pt2
         (if (> (distance n o) dist)
            (progn
               (if (and testpt (not (equal (distance o testpt) 0.0 0.001)))
                  (setq retpt o dist (distance n o))
               )
               (if (null testpt)
                 (setq retpt o dist (distance n o))
               )
            )
         )
      )
   )
   retpt
)



;--------------------------------------------------------------
; Main program
;
(defun c:glue  ( / ent1 ent2 temp lpt1 lpt2 lpt3 lpt4 endpt endpt1 midpt midpt1 pt1 pt2 pt3 pt4
                               elist1 elist2 ang1 ang2 es)
(prompt "\nGlue arcs, lines, text, 3dfaces together...")
(while (/= "Done" (setq es (entsel "\nPick first entity")))
   (setq ent1 (car es))
   (eval '(if ent1 (redraw ent1)))
   (redraw ent1 3)
   (while (not (setq ent2 (car (entsel "\nPick second entity" ))))
      (prompt "\nTry again.")
   )
   
   (setq elist1 (entget ent1) elist2 (entget ent2) pt1 nil pt2 nil pt3 nil pt4 nil)
   (cond
      ;*************** BOTH ARCS **********************************
      ((and ent1 ent2 (not (equal ent1 ent2)) (= (dxf 0 elist1) "ARC")
      (= (dxf 0 elist2) "ARC"))
      (setq pt1 (dxf 10 elist1)
         arclay (dxf 8 elist1); GET LAYER FROM FIRST ARC
         pt3 (dxf 10 elist2)
      )
      (if (equal (distance pt1 pt3) 0.0 0.001)
         (progn; SAME CENTER POINT
            (setq lpt1 (polar pt1 (dxf 50 elist1) (dxf 40 elist1))
               lpt2 (polar pt1 (dxf 51 elist1) (dxf 40 elist1))
               lpt3 (polar pt3 (dxf 50 elist2) (dxf 40 elist2))
               lpt4 (polar pt3 (dxf 51 elist2) (dxf 40 elist2))
               thick (dxf 39 elist1)
            )
           (if (< (distance lpt1 lpt4) (distance lpt2 lpt3)) 
               (command "_.arc" lpt3 lpt1 lpt2)           
               (command "_.arc" lpt1 lpt2 lpt4)           
            )
           
            (command "_.erase" ent1 ent2 ""); ERASE BOTH EXISTING ARCS
            (command "_.chprop" (entlast) "" "_la" arclay "_t" thick "")
          )
         (progn
            (eval '(if ent1 (redraw ent1)) zz#t)
            (prompt "\nArcs must have same center point")
         )
      )
   )
   ;*************** BOTH LINES **********************************
   ((and ent1 ent2 (not (equal ent1 ent2))
      (= (dxf 0 elist1) "LINE")
   (= (dxf 0 elist2) "LINE"))
   (setq lpt1 (dxf 10 elist1)
      lpt3 (dxf 10 elist2)
      lpt4 (dxf 11 elist2)
   )
   (command "_.erase" ent2 "")
   (setvar "orthomode" 0)
   (if (> (distance lpt1  lpt3) (distance lpt1 lpt4))
      (command "_.change" ent1 "" (trans lpt3 0 1))     
      (command "_.change" ent1 "" (trans lpt4 0 1))       
   )
   )
 
   ;
   ;*************** BOTH 3DFACES ********************************     
((and ent1 ent2 (not (equal ent1 ent2))
   (= (dxf 0 elist1) "3DFACE")
(= (dxf 0 elist2) "3DFACE"))
; create point list of each ent
(setq pt1 (cons (dxf 10 elist1) pt1)
   pt1 (cons (dxf 11 elist1) pt1)
   pt1 (cons (dxf 12 elist1) pt1)
   pt1 (cons (dxf 13 elist1) pt1)
   pt2 (cons (dxf 10 elist2) pt2)
   pt2 (cons (dxf 11 elist2) pt2)
   pt2 (cons (dxf 12 elist2) pt2)
   pt2 (cons (dxf 13 elist2) pt2)
)
; eval point lists
(if (and pt1 pt2)
   (progn
      ; find max points
      (setq lpt1 (pp_glue1 pt1 pt2 0 nil)
         lpt2 (glue1 pt1 pt2 0 lpt1)
         lpt3 (glue1 pt2 pt1 0 nil)
         lpt4 (glue1 pt2 pt1 0 lpt3)
      )
      ; erase existing faces
      (command "_.erase" ent1 ent2 "")
      ; create new face
      (if (inters lpt1 lpt4 lpt3 lpt2)
         (entmake
            (list (assoc 0 elist1) (assoc 8 elist1) (append '(10) lpt1)
               (append '(11) lpt3) (append '(12) lpt4) (append '(13) lpt2)
            )
         )
         (entmake
            (list (assoc 0 elist1)(assoc 8 elist1)(append '(10) lpt1)
               (append '(11) lpt4)(append '(12) lpt3)(append '(13) lpt2)
            )
         )
      )
   )
 )
);added 10-02-98
;*************** BOTH TEXT **********************************
((and ent1 ent2 (not (equal ent1 ent2))
   (= (dxf 0 elist1) "TEXT")
   (= (dxf 0 elist2) "TEXT"))
   (setq text1 (strcat (dxf 1 elist1) " " (dxf 1 elist2))
             elist1 (subst (cons 1 text1) (assoc 1 elist1) elist1)
   )
   (entdel ent2)
   (entmod elist1)
 )
;

;*************** SAME ENTITY *******************************
((equal ent1 ent2)
(eval '(if ent1 (redraw ent1)) zz#t)
(prompt  "\nDon't pick the same entity twice!")
)

;
;*************** MISMATCH **********************************
((and ent1 ent2)
(eval '(if ent1 (redraw ent1)) zz#t)
(prompt "\nThe 2 entities must be the same type.")
)
); end cond
); end while
(princ)
); end defun


Does the Architects drawing look like its been hand drawn,sketch effect and loads of broken lines?If so Ive met their realtives

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #6 on: February 04, 2006, 12:20:58 AM »
Gary,
Looking at your code, what happens when two lines share an end point but are not parallel?
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

hyposmurf

  • Guest
Re: Join lots of small lines
« Reply #7 on: February 04, 2006, 05:05:46 AM »
This was some code I'd found online and had stored away but had never felt the need to use.Youre correct it seems to run into problems.I looks like for instance two non parellel lines it deletes one of the lines and keep the other!Not a good result.Thanks for pointing that out.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #8 on: February 04, 2006, 10:22:11 AM »
I just threw this together with minimal testing.
See what you think. It mods the line picked first so the properties
of that line are preserved. Layer & Linetype

I'll get to the original question of doing all lines in the drawing at
one time later if I have time.

Code: [Select]
Up to date Code in Gary's post
« Last Edit: February 05, 2006, 05:03:41 PM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #9 on: February 04, 2006, 10:40:46 AM »
Allen

Thanks for the question, it has made me cleanup some old code I still had layiny around. It still amazes me how many routines I have floating around.
I thinks it's almost spring cleaning time. I think I will use your routine to replace my two.

Code: [Select]
Looking at your code, what happens when two lines share an end point but are not parallel?

Sorry I sent the wrong code, here is the one I use:
Code: [Select]
;;author unknown
(defun c:GU  (/ hdrlst ent ent1 ent2 val1 val2 valn params1 1pt10 1pt11 params2 2pt10 2pt11
              dist1 dist2 dist3 dist4 distlist maxdist pts pt10 pt11 params1 hdrlst)
  (setq clayer nil)
  (setq hdrlst (list (cons "limcheck" (getvar "limcheck"))
                     (cons "osmode" (getvar "osmode"))))
  (setvar "cmdecho" 0)
  (setvar "limcheck" 0)
  (setvar "osmode" 0)
  (setq ent1 (entsel "\n* Select first line *"))
  (if (eq (cdr (assoc 0 (entget (car ENT1)))) "TEXT")
    (progn (setq ent (entget (car ent1)))
           (setq ent2 (entget (car (entsel "\n* Select second Text *"))))
           (setq val1 (cdr (assoc 1 ent)))
           (setq val2 (cdr (assoc 1 ent2)))
           (setq valn (strcat val1 " " val2))
           (setq ent (subst (cons 1 valn) (assoc 1 ent) ent))
           (entmod ent)
           (entdel (cdr (assoc -1 ent2)))
           (princ))
    (progn (while ent1
             (redraw (setq ent1 (car ent1)) 3)
             (while (or (null (setq ent2 (entsel "\n* Select second line *")))
                        (if ent2
                          (equal (car ent2) ent1))))
             (redraw (setq ent2 (car ent2)) 3)
             (while (or (/= "LINE" (cdr (assoc 0 (entget ent1))))
                        (/= "LINE" (cdr (assoc 0 (entget ent2)))))
               (redraw ent1)
               (redraw ent2)
               (prompt "\n* The entities selected are not LINE entities *")
               (while (null (setq ent1 (entsel "\n* Select first line *"))))
               (redraw (setq ent1 (car ent1)) 3)
               (while (null (setq ent2 (entsel "\n* Select second line *"))))
               (redraw (setq ent2 (car ent2)) 3))
             (setq params1 (entget ent1))
             (setq 1pt10 (cdr (setq old10 (assoc 10 params1))))
             (setq 1pt11 (cdr (setq old11 (assoc 11 params1))))
             (setq params2 (entget ent2))
             (setq 2pt10 (cdr (assoc 10 params2)))
             (setq 2pt11 (cdr (assoc 11 params2)))
             (setq dist1 (distance 1pt10 2pt10))
             (setq dist2 (distance 1pt10 2pt11))
             (setq dist3 (distance 1pt11 2pt10))
             (setq dist4 (distance 1pt11 2pt11))
             (setq distlist
                    (list (list dist1 1pt10 2pt10)
                          (list dist2 1pt10 2pt11)
                          (list dist3 1pt11 2pt10)
                          (list dist4 1pt11 2pt11)))
             (setq maxdist (max dist1 dist2 dist3 dist4))
             (setq pts (cdr (assoc maxdist distlist)))
             (setq pt10 (car pts))
             (setq pt11 (cadr pts))
             (setq params1 (subst (cons 10 pt10) old10 params1))
             (setq params1 (subst (cons 11 pt11) old11 params1))
             (entdel ent2)
             (entmod params1)
             (entupd ent1)
             (setq ent1 (entsel "\n* Select first line *")))
           (foreach cnt hdrlst (setvar (car cnt) (cdr cnt)))
           (princ)))
  (princ))

Here is one for arcs:
Code: [Select]
;;; Author: Mark E. Leaf
(defun c:GUA (/ E1_DATA    E1_OBJ_TYPE  E1_CEN_PT
     E1_RADIUS E1_SA    E1_EA      E1_NAME  E2_DATA
     E2_OBJ_TYPE    E2_CEN_PT  E2_RADIUS  E2_SA
     E2_EA E2_NAME    E1_1ST_PT  E1_2ND_PT  E2_1ST_PT
     E2_2ND_PT D1    D2       D3  D4
     D5
    )
  (setvar "osmode" 0)
  (setvar "ErrNo" 0)
  (while (and (not (setq E1_DATA (entsel "\n* Select First Arc *")))
     (/= 52 (getvar "ErrNo"))
)
  )

  (cond
    (E1_DATA
     (setq E1_DATA (entget (car E1_DATA)))
     (setq E1_OBJ_TYPE (cdr (assoc 0 E1_DATA)))
;looking for "ARC" object type

     (while (and (/= E1_OBJ_TYPE "ARC") (/= 52 (getvar "ErrNo")))
       (alert "\nNo ARC Object Selected, Try Again!")
       (setvar "ErrNo" 0)
       (while
(and (not (setq E1_DATA (entsel "\n* Select First Arc *")))
     (/= 52 (getvar "ErrNo"))
)
       )
       (cond
(E1_DATA
 (setq E1_DATA (entget (car E1_DATA))) ;data base
 (setq E1_OBJ_TYPE (cdr (assoc 0 E1_DATA)))
;entity object type "ARC"
) ;end_E1_DATA nested
       ) ;end_cond
     ) ;end_while

     (if (= E1_OBJ_TYPE "ARC") ;if object "ARC" cont
       (progn
(setq E1_CEN_PT (cdr (assoc 10 E1_DATA)))
(setq E1_RADIUS (cdr (assoc 40 E1_DATA)))
(setq E1_SA (cdr (assoc 50 E1_DATA))) ;arc start angle
(setq E1_EA (cdr (assoc 51 E1_DATA))) ;arc end angle
(setq E1_NAME (cdr (assoc -1 E1_DATA))) ;entity name to entupd
       ) ;end_progn
     ) ;end_if

     (princ
       "\n* Base Arc Object Selected...select another Arc to add to it *"
     )

     (cond
       ((/= 52 (getvar "ErrNo")) ;if enter is hit exit
(setvar "ErrNo" 0)
(while (and (not (setq E2_DATA (entsel "\nSelect Second Arc")))
   (/= 52 (getvar "ErrNo"))
      )
)

(cond
 (E2_DATA
  (setq E2_DATA (entget (car E2_DATA))) ;database
  (setq E2_OBJ_TYPE (cdr (assoc 0 E2_DATA)))
;looking for "ARC" object type
  (setq E2_NAME (cdr (assoc -1 E2_DATA)))
;entity name to delete

  (while (and (/= E2_OBJ_TYPE "ARC") (/= 52 (getvar "ErrNo")))
    (alert "\nNo ARC Object Selected, Try Again!")
    (setvar "ErrNo" 0)
    (while
      (and
(not (setq E2_DATA (entsel "\n* Select Second Arc *")))
(/= 52 (getvar "ErrNo"))
      )
    )
    (cond
      (E2_DATA
(setq E2_DATA (entget (car E2_DATA))) ;data base
(setq E2_OBJ_TYPE (cdr (assoc 0 E2_DATA)))
;entity object type "ARC"
(setq E2_NAME (cdr (assoc -1 E2_DATA)))
;entity name to delete
      ) ;end_E2_DATA nested
    ) ;end_cond
  ) ;end_while

  (cond
    ((equal E1_NAME E2_NAME) ;if 1st entity is select again
     (alert "\nOriginal Entity Selected, Start again!")
     (setvar "ErrNo" 52)
    )
    ((/= E1_NAME E2_NAME) ;if 1st entity is select again
     (if (= E2_OBJ_TYPE "ARC") ;if object "ARC" cont
(progn
 (setq E2_CEN_PT (cdr (assoc 10 E2_DATA))
E2_RADIUS (cdr (assoc 40 E2_DATA))
E2_SA  (cdr (assoc 50 E2_DATA))
;arc start angle
E2_EA  (cdr (assoc 51 E2_DATA))
;arc end angle

E1_1ST_PT (polar E1_CEN_PT E1_SA E1_RADIUS)
;find startpoint of arc 1
E1_2ND_PT (polar E1_CEN_PT E1_EA E1_RADIUS)
;find endpoint of arc 1
E2_1ST_PT (polar E2_CEN_PT E2_SA E2_RADIUS)
;find startpoint of arcs 2
E2_2ND_PT (polar E2_CEN_PT E2_EA E2_RADIUS)
;find endpoint of arcs 2

D1  (distance E1_1ST_PT E2_1ST_PT)
;find dist from points of arc
D2  (distance E1_1ST_PT E2_2ND_PT)
D3  (distance E1_2ND_PT E2_1ST_PT)
D4  (distance E1_2ND_PT E2_2ND_PT)
D5  (min D1 D2 D3 D4)
 ) ;setq D5 to smallest dist

 (cond ;find shortest distance and find new start and end angles.
   ((= D1 D5)
    (setq NEW_SA E1_EA
  NEW_EA E2_EA
    )
   )
   ((= D2 D5)
    (setq NEW_SA E2_SA
  NEW_EA E1_EA
    )
   )
   ((= D3 D5)
    (setq NEW_SA E1_SA
  NEW_EA E2_EA
    )
   )
   ((= D4 D5)
    (setq NEW_SA E1_SA
  NEW_EA E2_SA
    )
   )
 ) ;end_cond

 (setq E1_DATA (subst (cons 50 NEW_SA)
      (assoc 50 E1_DATA)
      E1_DATA
)
 )
 (setq E1_DATA (subst (cons 51 NEW_EA)
      (assoc 51 E1_DATA)
      E1_DATA
)
 )
 (entdel E2_NAME)
 (entmod E1_DATA)
 (entupd E1_NAME)
) ;end_progn
     ) ;end_if
    ) ;end_(/= E1_NAME E2_NAME)
  ) ;end_cond (equal E1_NAME E2_NAME)

 ) ;end_E2_DATA
) ;end_E2_cond

       ) ;(/= 52 (getvar "ErrNo")
     ) ;end_cond (/= 52 (getvar "ErrNo")
    ) ;end_E1_DATA
  ) ;end_E1_cond
) ;end

Gary
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #10 on: February 04, 2006, 10:49:51 AM »
Sorry hyposmurf, I see that it was your code, and not Allens....I mean CAB's.

So do you want me to credit your code to hyposmurf, or use you real name, wich is?

Sorry, I'm for using real names and not code or nicknames.

Gary (and this is my real name) and yes I babble alot somethimes.
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #11 on: February 04, 2006, 11:45:04 AM »
Gary,
My code was derived from taking the first routine you posted apart & building it my way. :)

And the routine hyposmurf posted suffers the same problem with non-parallel lines.

Alan
« Last Edit: February 04, 2006, 11:48:14 AM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

LE

  • Guest
Re: Join lots of small lines
« Reply #12 on: February 04, 2006, 11:53:16 AM »
And how about design one to do it globally, instead of going in pair selections of lines ?

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #13 on: February 04, 2006, 01:08:33 PM »
Allen, I see that now, kool.

Luis, I'm all for that.
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #14 on: February 04, 2006, 01:13:05 PM »
Would it be better to make subfunctions local?

Code: [Select]
;;;Alan Butler 02/05/06
(defun c:glue  (/ flist slist f1pt f2pt s1pt s2pt flin slin fuzz p1 p2 p3 p4 overlap parallel)
  ;; determine if p1 & p4 are in the same direction
  (defun overlap (p1 p2 p3 p4) (equal (angle p2 p1) (angle p3 p4) 1.001))
  ;;  test for parallel   CAB 10/18/05
  (defun parallel  (ln1 ln2 / ang1 ang2 pfuzz)
    (if (= (type ln1) 'ename)
      (setq ln1 (entget ln1)
            ln2 (entget ln2)))
    (setq ang1 (angle (cdr (assoc 10 ln1)) (cdr (assoc 11 ln1))))
    (setq ang2 (angle (cdr (assoc 10 ln2)) (cdr (assoc 11 ln2))))
    (setq pfuzz 0.001)
    (or (equal ang1 ang2 pfuzz)
        ;;  Check for lines drawn in opposite directions
        (equal (min ang1 ang2) (- (max ang1 ang2) pi) pfuzz)))
  ;;  ***  Start of Routine  ***
  (if (and (setq flin (car (entsel "\n* Pick first Line *")))
           (setq slin (car (entsel "\n* Pick second Line *"))))
    (progn (setq fuzz 0.01) ; alowable line endpoint gap
           (setq flist (entget flin))
           (setq slist (entget slin))
           (if (parallel flist slist)
             (progn (setq f1pt (cdr (assoc 10 flist)))
                    (setq f2pt (cdr (assoc 11 flist)))
                    (setq s1pt (cdr (assoc 10 slist)))
                    (setq s2pt (cdr (assoc 11 slist)))
                    ;;  find end point match
                    (cond ((< (distance f1pt s1pt) fuzz)
                           (setq p1 f2pt ; start of new line
                                 p2 f1pt ; intersect of old lines
                                 p3 s1pt ; intersect of old lines
                                 p4 s2pt ; end of new line
                                 ))
                          ((< (distance f2pt s1pt) fuzz)
                           (setq p1 f1pt  p2 f2pt  p3 s1pt  p4 s2pt))
                          ((< (distance f1pt s2pt) fuzz)
                           (setq p1 f2pt  p2 f1pt  p3 s2pt  p4 s1pt))
                          ((< (distance f2pt s2pt) fuzz)
                           (setq p1 f1pt  p2 f2pt  p3 s2pt  p4 s1pt))
                          ((prompt "\n* Error, Lines not end to end *")))
                    (if p1
                      (if (not (overlap p1 p2 p3 p4))
                        (progn
                          (cond
                            ((equal p1 (cdr (assoc 11 flist)))
                             (setq flist (subst (cons 10 p4) (assoc 10 flist) flist)))
                            ((equal p4 (cdr (assoc 10 flist)))
                             (setq flist (subst (cons 11 p1) (assoc 11 flist) flist)))
                            ((setq flist (subst (cons 10 p1) (assoc 10 flist) flist)
                                   flist (subst (cons 11 p4) (assoc 11 flist) flist)))
                          )
                               (entmod flist) ; keeps the same properties of the first line
                               (entdel slin) ; second line is discarded
                               )
                        (prompt "\n* Error, Lines overlap, not end to end *"))))
             (prompt "\n* Error, Lines are not parallel * ")))
    (prompt "\n* Missed the pick *"))
  (princ))
(prompt "\nGlue Lines Loaded, Enter Glue to run.")
(princ)
[edit: One More Time. Bug Fix 8:34pm  :)]
« Last Edit: February 05, 2006, 08:37:51 PM by CAB »
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #15 on: February 04, 2006, 01:33:04 PM »
Oh yes..

That was just a rough draft. :-)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #16 on: February 04, 2006, 01:50:26 PM »
Gary
I edited the code in your post, adding some needed local vars & condesing it further.
Hope you don't mind.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

GDF

  • Water Moccasin
  • Posts: 2081
Re: Join lots of small lines
« Reply #17 on: February 04, 2006, 01:53:00 PM »
Allen

Thanks, I'm learning...............
Why is there never enough time to do it right, but always enough time to do it over?
BricsCAD 2020x64 Windows 10x64

Fatty

  • Guest
Re: Join lots of small lines
« Reply #18 on: February 05, 2006, 04:05:43 PM »
Maybe this need somebody else

Code: [Select]
;; | --------------------------------------------------------------------------
;; | PEDLINES.lsp
;; | --------------------------------------------------------------------------
;; | Returns  : Polyline entity
;; | Updated  : 2/5/06
;; | Author   : Fatty
;; | Note     : Multiple join of lines by picking first or last line in the chain
;; | ----------------------------------------------------------------------------

(defun pedlines (fuzz /    acsp     adoc     axss     chain_list
   couple   ept     line_list       ln       loop
   spt    ss
  )
 (vl-load-com)
 (or adoc
     (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
 )
  (setvar "cmdecho" 0)
 (setq ln  (vlax-ename->vla-object (car (entsel
"\n\t >> Select first or last line in the line chain >>\n")))
spt (vlax-get ln 'Startpoint)
ept (vlax-get ln 'Endpoint)
 )

 (setq ss   (ssget "_X" '((0 . "LINE")))
axss (vla-get-activeselectionset adoc)
 )

 (setq line_list '()
chain_list
 (cons ln chain_list)
 )
 (vlax-for a axss (setq line_list (cons a line_list)))

 (setq loop t)
 (while loop
   (while
     (setq couple
     (vl-remove-if-not
       (function (lambda (x)
     (or (equal (vlax-get x 'Startpoint)
         (vlax-get ln 'Startpoint)
         fuzz
         )
         (equal (vlax-get x 'Startpoint)
         (vlax-get ln 'Endpoint)
         fuzz
         )
         (equal (vlax-get x 'Endpoint)
         (vlax-get ln 'Startpoint)
         fuzz
         )
         (equal (vlax-get x 'Endpoint)
         (vlax-get ln 'Endpoint)
         fuzz
         )
     )
   )
       )
       line_list
     )
     )
      (if couple
 (progn
   (setq chain_list (append couple chain_list))

   (setq line_list (vl-remove ln line_list))
   (setq ln (car chain_list))
 )
 (setq line_list (cdr line_list))
      )
   )
   (setq loop nil)
 )

(command "pedit" "m")
(mapcar 'command (mapcar 'vlax-vla-object->ename chain_list))
(command "" "Y" "J" "" "")
(setvar "cmdecho" 1) 
(entlast)
)
;TesT : (pedlines 0.01); 0.01 in drawing units

~'J'~

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #19 on: February 05, 2006, 06:04:10 PM »
Here is my attempt.
Could use more testing.
Also attached is a test dwg that i used.
Note that Luis's code left some unattached in my test.

Code: [Select]
;;;=======================[ GlueAllLines.lsp ]=======================
;;; Author: Copyright© 2006 Charles Alan Butler
;;; Version:  1.1 Feb 09, 2006
;;; Purpose: To glue all lines that are end to end & on the same layer
;;;          and not on a locked layer
;;;          Selection is by user or current space or all drawing
;;; Sub_Routines: ss->lst creates a data list of all the lines
;;;               glue  will glue two lines
;;; Requirements: None   
;;;                       
;;;==============================================================

(defun c:GlueAllLines (/ masterlist itm lay tmp newlst layidx taridx laygroup
                       fuzz elst idx newln newtarget ss target)
                       
;;; -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=-
;;;                                                               -
;;;                        Functions                              -
;;;                                                               -
;;; -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=- -=<*>=-
 
  ;;====================================================================
  ;;  returns a list of enity info ((ename layer stpt endpt space) ...)
  (defun ss->lst (ss2 / i ename result elst)
    (setq i -1)
    (while (setq ename (ssname ss2 (setq i (1+ i))))
      (setq elst   (entget ename)
            result (cons
                     (list ename                  ; ent name
                           (cdr (assoc 8 elst))   ; layer
                           (cdr (assoc 10 elst))  ; start pt
                           (cdr (assoc 11 elst))  ; end pt
                           (cdr (assoc 410 elst)) ; space
                     )
                     result
   ))))

 
  ;;Alan Butler 02/05/06
  ;;  returns nil if lines are not joined
  (defun glue  (flin slin / p1 p2 p3 p4 flist slist f1pt f2pt s1pt s2pt overlap parallel fuzz)
    ;; determine if p1 & p4 are in the same direction
    (defun overlap (p1 p2 p3 p4) (equal (angle p2 p1) (angle p3 p4) 1.001))
    ;;  test for parallel   CAB 10/18/05
    (defun parallel  (ln1 ln2 / ang1 ang2 pfuzz)
      (if (= (type ln1) 'ename)
        (setq ln1 (entget ln1)
              ln2 (entget ln2)))
      (setq ang1 (angle (cdr (assoc 10 ln1)) (cdr (assoc 11 ln1))))
      (setq ang2 (angle (cdr (assoc 10 ln2)) (cdr (assoc 11 ln2))))
      (setq pfuzz 0.001)
      (or (equal ang1 ang2 pfuzz)
          ;;  Check for lines drawn in opposite directions
          (equal (min ang1 ang2) (- (max ang1 ang2) pi) pfuzz)))
    ;;  ***  Start of Routine  ***
    (if (and flin slin)
      (progn (setq fuzz 0.01) ; alowable line endpoint gap
             (setq flist (entget flin))
             (setq slist (entget slin))
             (if (parallel flist slist)
               (progn (setq f1pt (cdr (assoc 10 flist)))
                      (setq f2pt (cdr (assoc 11 flist)))
                      (setq s1pt (cdr (assoc 10 slist)))
                      (setq s2pt (cdr (assoc 11 slist)))
                      ;;  find end point match
                      (cond ((< (distance f1pt s1pt) fuzz)
                             (setq p1 f2pt ; start of new line
                                   p2 f1pt ; intersect of old lines
                                   p3 s1pt ; intersect of old lines
                                   p4 s2pt ; end of new line
                                   ))
                            ((< (distance f2pt s1pt) fuzz)
                             (setq p1 f1pt  p2 f2pt  p3 s1pt  p4 s2pt))
                            ((< (distance f1pt s2pt) fuzz)
                             (setq p1 f2pt  p2 f1pt  p3 s2pt  p4 s1pt))
                            ((< (distance f2pt s2pt) fuzz)
                             (setq p1 f1pt  p2 f2pt  p3 s2pt  p4 s1pt)))
                      (if (and p1 (not (overlap p1 p2 p3 p4)))
                        (progn
                          (cond
                            ((equal p1 (cdr (assoc 11 flist)))
                             (setq flist (subst (cons 10 p4) (assoc 10 flist) flist)))
                            ((equal p4 (cdr (assoc 10 flist)))
                             (setq flist (subst (cons 11 p1) (assoc 11 flist) flist)))
                            ((setq flist (subst (cons 10 p1) (assoc 10 flist) flist)
                                   flist (subst (cons 11 p4) (assoc 11 flist) flist)))
                          )
                          (entmod flist) ; keeps the same properties of the first line
                          (entdel slin) ; second line is discarded
                       )))
      )))
    )

 
  ;; o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o
  ;;                S T A R T   O F   R O U T I N E               
  ;; o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o-o

  (prompt "\nSelect lines to join or Enter for all lines in drawing.")
  (if (or (setq ss (ssget '((0 . "LINE")))) ; user selected lines
          (and (not (initget "Yes No"))
               (/= (getkword "\n***  Limit to lines in current space? <Yes>  ***") "No")
               (setq ss (ssget "_X" (list '(0 . "LINE")(cons 410 (getvar "ctab")))))
          )
          (setq ss (ssget "_X" '((0 . "LINE"))))) ; get all lines
    (progn
      (command ".undo" "begin")
      (setq masterlist (ss->lst ss)) ; create a list of entity data
      ;;  sort the list on layer
      (setq masterlist (vl-sort masterlist '(lambda (e1 e2) (< (cadr e1) (cadr e2)))))
      (setq lay (cadar masterlist)) ; first layer
      ;;  create sub list grouped by layer
      (foreach itm masterlist
        (if (= lay (cadr itm))
          (setq tmp (cons itm tmp))
            (setq newlst (cons tmp newlst)
                  tmp    (list itm)
                  lay    (cadr itm)
            )
        )
      )
      (if tmp (setq newlst (cons tmp newlst)))
     
      ;;  foreach layer group
      ;;  Note that a WHILE is used as FOREACH will not handle changing list
      (setq layidx -1)
      (while (< (setq layidx (1+ layidx)) (length newlst))
        ;;  foreach item check with the other items for a match
        (setq taridx -1)
        (setq laygroup (nth layidx newlst))
        (while (< (setq taridx (1+ taridx)) (length laygroup))
          (if (setq target (nth taridx laygroup))
            (progn
              ;;  foreach other item combine lines within layer groups
              (setq idx -1)
              (while (< (setq idx (1+ idx)) (length laygroup))
                (if (and (setq itm (nth idx laygroup)) ; check for nil -> removed line
                         (not (equal (car target) (car itm)))
                         (= (nth 4 target) (nth 4 itm)) ;  in same space? model or layouts
                    )
                  ;;  try to glue the lines
                  (if (glue (car target) (car itm))
                    ;;  they are joined, so update list
                    ;;  update the sublist, new end points & nil deleted line
                    (setq elst     (entget (car target))
                          newtarget (list (car target)           ; ent name
                                          (cdr (assoc 8 elst))   ; layer
                                          (cdr (assoc 10 elst))  ; start pt
                                          (cdr (assoc 11 elst))  ; end pt
                                          (cdr (assoc 410 elst)) ; space
                                    )
                          laygroup  (subst newtarget target laygroup)
                          laygroup  (subst nil itm laygroup) ; remove deleted line, nil will be a place holder
                          target    newtarget
                          idx       -1 ; start the loop again because the targat end points changed
                    )
                  )
                )
              )
            )
           )
          )
        ) ; while
      (command ".undo" "end")
    )
  )
  (princ)
)
(prompt "\nGlue All Lines Loaded, Enter GlueAllLines to run.")
(princ)


Updated code again 02/09/06
« Last Edit: February 09, 2006, 10:08:50 AM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

LE

  • Guest
Re: Join lots of small lines
« Reply #20 on: February 05, 2006, 06:58:18 PM »
Here is my attempt.
Could use more testing.
Also attached is a test dwg that i used.
Note that Luis's code left some unattached in my test.

Hi Charles;

I just did a test using your drawing sample, my command glues all the possible collinear lines, I tried with yours and does not do anything.

Luis.
« Last Edit: February 06, 2006, 12:45:47 PM by LE »

Serge J. Gianolla

  • Guest
Re: Join lots of small lines
« Reply #21 on: February 05, 2006, 07:28:14 PM »
Hudster,
On your post you mention Having 2006, any reason why you are not using the built-in command Join if indeed you are talking about colinear lines? If they are not colinear, use the PEdit function combined with Fast Select from the express tools. You can use it transparently as such 'FS when prompted to select all objects to join. FastSel is an open lisp file; a couple of added lines should be enough to select only object belonging to same layer.
HTH

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #22 on: February 05, 2006, 08:35:19 PM »
Luis,
i fixed it. Thanks
When I stripped out the debug code I stripped too much. :-)
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

LE

  • Guest
Re: Join lots of small lines
« Reply #23 on: February 05, 2006, 10:36:48 PM »
Luis,
i fixed it. Thanks
When I stripped out the debug code I stripped too much. :-)

It is working now... just for lines that touch each other [as the OP asked]... but it takes a lot of time to process the items... as I know still is code in progress...

Thanks  :-)

sinc

  • Guest
Re: Join lots of small lines
« Reply #24 on: February 09, 2006, 07:53:51 AM »
Hudster,
On your post you mention Having 2006, any reason why you are not using the built-in command Join if indeed you are talking about colinear lines? If they are not colinear, use the PEdit function combined with Fast Select from the express tools. You can use it transparently as such 'FS when prompted to select all objects to join. FastSel is an open lisp file; a couple of added lines should be enough to select only object belonging to same layer.
HTH


To play on this answer, you can also use the "Multiple" option of PEdit.  You probably want to set PEDITACCEPT to 1.  Then type PEdit, then hit M.  Select all lines/arcs you want joined.  Type "J" for Join.  Enter a "fuzz distance" at the prompt.  You should now have a set of polylines.

Also, I still use QuickSelect, but one my favorite ways for selecting objects has become the Express Tools command "Get Selection Set" (GETSEL).  To use this command, run GETSEL first, before running your other command (GETSEL doesn't work transparently).  First option is to pick an object on the layer you want (hit return or right-click for ALL LAYERS), then pick the type of object you want (hit return or right-click for ALL OBJECTS).  The objects will go into the current selection set.  Then, when you run your command and it asks you to select objects, hit "P" for "Previous selection set".

This works in 2004 and up; I don't know about earlier versions.

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #25 on: February 09, 2006, 08:55:52 AM »
Andy where did you go?


Sinc, the GetSel works for me in ACAD2000
Have you tried my Sel routine?  Sel.lsp   It doesn't work transparently eather.
But it lets you choose more than one layer & then lets you select all or a window to filter from.
No object type filter though.

« Last Edit: February 09, 2006, 09:02:45 AM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

hudster

  • Gator
  • Posts: 2848
Re: Join lots of small lines
« Reply #26 on: February 09, 2006, 09:22:57 AM »
isn't getsel an express tools command?
Revit BDS 2017, 2016, 2015, 2014, AutoCAD 2017, 2016, Navisworks 2017, 2016, BIM360 Glue

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #27 on: February 09, 2006, 09:37:46 AM »
isn't getsel an express tools command?
Yes. and my Sel routine is similar in the way it works.

The problem I have with getsel is that in my et version you can not limit the
the objects to be considered for the selection. It get the entire drawing or at
least the entire space.


Did you get your problem solved as for joining lines?
« Last Edit: February 09, 2006, 09:40:53 AM by CAB »
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

hudster

  • Gator
  • Posts: 2848
Re: Join lots of small lines
« Reply #28 on: February 09, 2006, 09:41:46 AM »
Yeah I used the gluelines routine, had to be selective on what i picked, but it joined all the lines nicely
Revit BDS 2017, 2016, 2015, 2014, AutoCAD 2017, 2016, Navisworks 2017, 2016, BIM360 Glue

LE

  • Guest
Re: Join lots of small lines
« Reply #29 on: February 09, 2006, 10:00:44 AM »
Yeah I used the gluelines routine, had to be selective on what i picked, but it joined all the lines nicely

Andy;

Since I am using GLUELINES to learn and implement the most I can about classes... I am doing some upgrades for the application - still will be a freeone.

By adding some filter options:
1. Layer
2. Linetype
3. Color

I know that the command OVERKILL does something similar... I will say that my version is going to be another alternative.

As soon I have ready.... it will be available for download right on the "show my stuff"... section.

Have fun.

Note:
Regarding the issues about relying on a 3d party application and the possibility of not having this command available to run on future releases of AutoCAD.
The source code including the C++ project solution and line by line description, MIGHT be available for a FEE

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Join lots of small lines
« Reply #30 on: February 09, 2006, 10:12:29 AM »
Yeah I used the gluelines routine, had to be selective on what i picked, but it joined all the lines nicely
I update my GlueAllLines routine to allow the user to select via window or pick the lines to consider.
If enter is pressed the user is prompted to restrict the selection to current space else the entire drawing is used.


BTW good work Luis, I'm watching you progress. Thanks
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.