Jump to content

Join multiple collinear polylines

handasa

By handasa
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

handasa Community Regular

handasa

Posted
Posted

GREETINGS EVERY ONE

attachment.php?attachmentid=57781&cid=1&stc=1

 

I HAVE THESE POLYLINES AND WANT TO CLOSE THESE GAPS IN BETWEEN WITH A SINGLE COMMAND

ANY SUGGESTIONS...

THANKS IN ADVANCE

WDEFG.PNG

Link to comment
Share on other sites
handasa Community Regular

handasa

Posted
  • Author
Posted

THIS LISP BY LEE MAC WORK ONLY FOR LINES

;; Join Lines  -  Lee Mac
;; Joins collinear lines in a selection, retaining all original properties.

(defun c:joinlines ( / process e i l s x )

   (defun process ( l / x r )
       (if (setq x (car l))
           (progn
               (foreach y (cdr l)
                   (if (vl-every '(lambda ( a ) (apply 'LM:collinear-p (cons a (cdr x)))) (cdr y))
                       (setq x (cons (car x) (LM:furthestapart (append (cdr x) (cdr y)))))
                       (setq r (cons y r))
                   )
               )
               (entmake (append (car x) (mapcar 'cons '(10 11) (cdr x))))
               (process r)
           )
       )
   )
   (if (setq s (ssget "_:L" '((0 . "LINE"))))
       (process
           (repeat (setq i (sslength s))
               (setq e (ssname s (setq i (1- i)))
                     x (entget e)
                     e (entdel e)
                     l (cons (list x (cdr (assoc 10 x)) (cdr (assoc 11 x))) l)
               )
           )
       )
   )
   (princ)
)

;; Furthest Apart  -  Lee Mac
;; Returns the two points furthest apart in a given list

(defun LM:furthestapart ( lst / di1 di2 pt1 rtn )
   (setq di1 0.0)
   (while (setq pt1 (car lst))
       (foreach pt2 (setq lst (cdr lst))
           (if (< di1 (setq di2 (distance pt1 pt2)))
               (setq di1 di2
                     rtn (list pt1 pt2)
               )
           )
       )
   )
   rtn
)

;; Collinear-p  -  Lee Mac
;; Returns T if p1,p2,p3 are collinear

(defun LM:Collinear-p ( p1 p2 p3 )
   (
       (lambda ( a b c )
           (or
               (equal (+ a b) c 1e-
               (equal (+ b c) a 1e-
               (equal (+ c a) b 1e-
           )
       )
       (distance p1 p2) (distance p2 p3) (distance p1 p3)
   )
)

(princ)

Link to comment
Share on other sites
benhubel Enthusiast

benhubel

Posted
Posted

It works on polylines that are made up of lines as well. I haven't tried it on any polylines with curves in them, so I can't speak to that. It's one of my essential routines.

Link to comment
Share on other sites
BIGAL Grand Master

BIGAL

Posted
Posted

Another version, it does not check for collinear.

 

; by Alan H
(defun AH:Fmulti ( / ss fpts num num2 x y)
(alert "pick outside-inside-outside")
(setq fpts '())

(setq fpts (cons (getpoint "Pick outside")fpts))
(setq fpts (cons (getpoint "Pick inside") fpts))
(setq fpts (cons (getpoint "Pick outside") fpts))

(setq ss (ssget "F" fpts (list (cons 0 "LINE"))))
(setq num (sslength ss))
(setq num2 (/ num 2.0))
(if (= (- (fix num2) num2) 0.5)
(progn
(Alert "you have an odd number of lines please check")
(exit)
)
)

(setq x 0)
(setq y (- num 1))
(setvar "filletrad" 0.0)
(repeat (fix num2) ; not a real
(setq obj1 (ssname ss x))
(setq obj2 (ssname ss y))
(command "fillet" obj1 obj2)
(setq x (+ x 1))
(setq y (- y 1))
)

) ; defun
(AH:fmulti)

Link to comment
Share on other sites
handasa Community Regular

handasa

Posted
  • Author
Posted

this lisp fillet lines which i don't need ... i just want to close the gaps between the separate polylines ... closing the gaps using the mpedit doesn't work either as it closes each neighbor polylines as follow

attachment.php?attachmentid=57794&cid=1&stc=1

frffbfbf.PNG

Link to comment
Share on other sites
eldon Grand Master

eldon

Posted
Posted

Perhaps you might consider two commands instead of one, and this procedure would only work if your lines were orthogonal straight lines.

 

You could STRETCH the lines from A to B, and then you could ERASE the existing short lines.

CloseGap.PNG

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted (edited)

Well, what can I say... You can try this, but it's just a little buggus... Maybe someone will be able in future to implement it correctly... It was designed to work and with arced segments...

 

(defun c:joinlws ( / *error* clockwise-p LM:Bulge->Arc LM:Arc->Bulge fls fas fle fae *adoc* ss fuzz i lw sp np pp ep sb pb l ll chain d nd dl dll s overkillA2012- qaf pea )

 (vl-load-com)

 (defun *error* ( m )
   (if qaf
     (setvar 'qaflags qaf)
   )
   (if pea
     (setvar 'peditaccept pea)
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clockwise-p ( p1 p p2 )
   (minusp (- (* (car (mapcar '- p1 p)) (cadr (mapcar '- p2 p))) (* (cadr (mapcar '- p1 p)) (car (mapcar '- p2 p)))))
 )

 ;; Bulge to Arc  -  Lee Mac - mod by M.R.
 ;; p1 - start vertex
 ;; p2 - end vertex
 ;; b  - bulge
 ;; Returns: (<center> <start angle> <end angle> <radius>)

 (defun LM:Bulge->Arc ( p1 p2 b / a c r )
     (setq a (* 2 (atan (abs b)))
           r (abs (/ (distance p1 p2) 2 (sin a)))
           c (if (minusp b) (polar p2 (+ (- (/ pi 2) a) (angle p2 p1)) r) (polar p1 (+ (- (/ pi 2) a) (angle p1 p2)) r))
     )
     (list c (angle c p1) (angle c p2) r)
 )

 ;; Arc to Bulge  -  Lee Mac - mod by M.R.
 ;; c     - center
 ;; a1,a2 - start, end angle
 ;; r     - radius
 ;; lw    - LWPOLYLINE ename
 ;; Returns: (<vertex> <bulge> <vertex>)

 (defun LM:Arc->Bulge ( c a1 a2 r lw / b flip )

   (if
     (and
       (vl-member-if '(lambda ( x ) (equal (cdr x) (mapcar '+ '(0.0 0.0) (polar c a2 r)) 0.05)) (cdr (vl-member-if '(lambda ( x ) (equal (cdr x) (mapcar '+ '(0.0 0.0) (polar c a1 r)) 0.05)) (entget lw))))
       (not (equal (setq b (cdr (assoc 42 (cdr (vl-member-if '(lambda ( x ) (equal (cdr x) (mapcar '+ '(0.0 0.0) (polar c a1 r)) 0.05)) (entget lw)))))) ( (lambda ( a ) (/ (sin a) (cos a))) (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0) ) 1e-6))
     )
     (setq flip t)
   )

   (list
     (polar c a1 r)
     (if (equal b
       (if flip
         (- (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                   (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
                 )
            )
         )
         (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
              )
         )
       )
       0.05)
       (if flip
         (- (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                   (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
                 )
            )
         )
         (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
              )
         )
       )
       (if flip
         (- (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                   (/ (rem (+ pi pi (- a1 a2)) (+ pi pi)) 4.0)
                 )
            )
         )
         (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                (/ (rem (+ pi pi (- a1 a2)) (+ pi pi)) 4.0)
              )
         )
       )
     )
     (polar c a2 r)
   )
 )

 (defun fls ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadr a) (cadr d)) (distance (cadr b) (cadr d))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadddr a) (cadr d)) (distance (cadddr b) (cadr d))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (distance (cadr (car lst1)) (cadr d)) (distance (cadddr (car lst2)) (cadr d)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fas ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr a) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr b) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr a) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr b) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr (car lst1)) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr (car lst2)) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fle ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadr a) (cadddr d)) (distance (cadr b) (cadddr d))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadddr a) (cadddr d)) (distance (cadddr b) (cadddr d))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (distance (cadr (car lst1)) (cadr d)) (distance (cadddr (car lst2)) (cadr d)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fae ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr a) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr b) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr a) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr b) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr (car lst1)) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr (car lst2)) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (prompt "\nSelect open LWPOLYLINES to process...")
 (setq ss (ssget "_:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>"))))
 (initget 6)
 (setq fuzz (getdist "\nPick or specify fuzz gap distance between adjacent LWPOLYLINES <5e-3> : "))
 (if (null fuzz)
   (setq fuzz 5e-3)
 )
 (repeat (setq i (sslength ss))
   (setq lw (ssname ss (setq i (1- i))))
   (setq sp (trans (vlax-curve-getstartpoint lw) 0 1))
   (setq np (trans (vlax-curve-getpointatparam lw 1.0) 0 1))
   (setq pp (trans (vlax-curve-getpointatparam lw (1- (vlax-curve-getendparam lw))) 0 1))
   (setq ep (trans (vlax-curve-getendpoint lw) 0 1))
   (setq sb (vla-getbulge (vlax-ename->vla-object lw) 0.0))
   (setq pb (vla-getbulge (vlax-ename->vla-object lw) (1- (vlax-curve-getendparam lw))))
   (setq ll (cons (list (list t sp sb np) (list nil pp pb ep)) ll))
   (setq l (cons (list t sp sb np) l) l (cons (list nil pp pb ep) l))
 )

 (defun chain ( d l )
   (cond
     ( (eq (car d) t)
       (if (zerop (caddr d))
         (setq nd (fls d l))
         (setq nd (fas d l))
       )
     )
     ( (null (car d))
       (if (zerop (caddr d))
         (setq nd (fle d l))
         (setq nd (fae d l))
       )
     )
   )
   (cond
     ( (and nd (not (equal (cdr nd) (cdr d) 1e-) (null dl))
       (setq dl (list d))
       (setq dl (append dl (list nd)))
     )
     ( (and nd (not (equal (cdr nd) (cdr d) 1e-) dl)
       (setq dl (append dl (list nd)))
     )
   )
   (if nd
     dl
   )
 )

 (foreach d l
   (foreach pair ll
     (if (or (equal d (car pair) 1e- (equal d (cadr pair) 1e-)
       (progn
         (setq dl (chain d (vl-remove (cadr pair) (vl-remove (car pair) l))))
         (if dl
           (setq dll (cons (list pair dl) dll))
         )
       )
     )
   )
   (setq dl nil)
 )

 (setq s (ssadd))
 (foreach dl dll
   (setq d (caadr dl) nd (cadadr dl))
   (if (zerop (caddr d))
     (cond
       ( (equal nd (fls d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
         (ssadd (entmakex (list '(0 . "LINE") (cons 10 (if (equal (distance (cadr nd) (cadddr d)) (+ (distance (cadr nd) (cadr d)) (distance (cadr d) (cadddr d))) 1e-6) (trans (cadr nd) 1 0) (trans (cadddr nd) 1 0))) (cons 11 (trans (cadr d) 1 0)))) s)
       )
       ( (equal nd (fle d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
         (ssadd (entmakex (list '(0 . "LINE") (cons 10 (if (equal (distance (cadr nd) (cadr d)) (+ (distance (cadr nd) (cadddr d)) (distance (cadddr d) (cadr d))) 1e-6) (trans (cadr nd) 1 0) (trans (cadddr nd) 1 0))) (cons 11 (trans (cadddr d) 1 0)))) s)
       )
     )
     (cond
       ( (equal nd (fas d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
         (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d)))
         (if (< (distance (cadr d) (cadr nd)) (distance (cadr d) (cadddr nd)))
           (if (not (equal (cadr d) (cadr nd) 1e-6))
             (if (not (clockwise-p (cadr d) (car ***) (cadr nd)))
               (command "_.ARC" "_non" (cadr d) "_C" "_non" (car ***) "_non" (cadr nd))
               (command "_.ARC" "_non" (cadr nd) "_C" "_non" (car ***) "_non" (cadr d))
             )
           )
           (if (not (equal (cadr d) (cadddr nd) 1e-6))
             (if (not (clockwise-p (cadr d) (car ***) (cadddr nd)))
               (command "_.ARC" "_non" (cadr d) "_C" "_non" (car ***) "_non" (cadddr nd))
               (command "_.ARC" "_non" (cadddr nd) "_C" "_non" (car ***) "_non" (cadr d))
             )
           )
         )
         (ssadd (entlast) s)
       )
       ( (equal nd (fae d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
         (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d)))
         (if (< (distance (cadddr d) (cadr nd)) (distance (cadddr d) (cadddr nd)))
           (if (not (equal (cadddr d) (cadr nd) 1e-6))
             (if (not (clockwise-p (cadddr d) (car ***) (cadr nd)))
               (command "_.ARC" "_non" (cadddr d) "_C" "_non" (car ***) "_non" (cadr nd))
               (command "_.ARC" "_non" (cadr nd) "_C" "_non" (car ***) "_non" (cadddr d))
             )
           )
           (if (not (equal (cadddr d) (cadddr nd) 1e-6))
             (if (not (clockwise-p (cadddr d) (car ***) (cadddr nd)))
               (command "_.ARC" "_non" (cadddr d) "_C" "_non" (car ***) "_non" (cadddr nd))
               (command "_.ARC" "_non" (cadddr nd) "_C" "_non" (car ***) "_non" (cadddr d))
             )
           )
         )
         (ssadd (entlast) s)
       )
     )
   )
 )

 (setq qaf (getvar 'qaflags))
 (setvar 'qaflags 1)
 (command "_.EXPLODE" ss)
 (while (< 0 (getvar 'cmdactive))
   (command "")
 )
 (setq ss (ssget "_P"))
 (repeat (setq i (sslength s))
   (ssadd (ssname s (setq i (1- i))) ss)
 )

 (setq s ss)
 (defun overkillA2012- ( ss / lst )
   (load "overkill.lsp")
   (acet-error-init 
     (list '("cmdecho" 0)
            T
     )
   )
   (setq ss (car (acet-ss-filter (list ss nil T))))
   (setq lst
     (list
       (max (acet-overkill-fuz-get) 1.0e-04)
       (acet-overkill-ignore-get)
       (acet-overkill-no-plines-get)
       (acet-overkill-no-partial-get)
       (acet-overkill-no-endtoend-get)
     )
   )
   (setq lst (cons ss lst))
   (acet-overkill2 lst)
   (acet-error-restore)
 )

 (if (< (atof (getvar 'acadver)) 18.2)
   (overkillA2012- ss)
   (progn
     (command "_.-OVERKILL" ss "" "_O" 1e-4 "_I" "_A" "_P" "_N" "_T" "_Y" "_E" "_Y" "")
     (while (< 0 (getvar 'cmdactive))
       (command "")
     )
   )
 )
 (repeat (setq i (sslength s))
   (if (not (entget (ssname s (setq i (1- i)))))
     (ssdel (ssname s i) s)
   )
 )
 (setq pea (getvar 'peditaccept))
 (setvar 'peditaccept 1)
 (command "_.PEDIT" "_M" s "" "_J" "_J" "_E" fuzz)
 (while (< 0 (getvar 'cmdactive))
   (command "")
 )
 (*error* nil)
)

On attached file it didn't work as expected - perfectly... Sorry... M.R.

:(

 

[EDIT : Attached is lisp that should work fine for any 3D LWPOLYLINES orientations... Posted code should do it only for UCS aligned with selected LWPOLYLINES, but in lisp it's implemented also (overkill-MR) sub function that should take care of overlapping duplicates for sure...]

joinlws.dwg

joinlws.lsp

Edited by marko_ribar
code changed...
  • Like 1
Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted
marko_ribar

your lisp works quite well

just the generated pollylines need to be segement optimized to remove unneeded vertices

 

I've updated the code... Should be much better now... HTH, M.R.

Link to comment
Share on other sites
handasa Community Regular

handasa

Posted
  • Author
Posted

marko_ribar

great work ... works as expected after modifying a little thing in it

i changed

(command "_.-OVERKILL" ss "" "_O" fuzz "_I" "_A" "_P" "_N" "_T" "_Y" "_E" "_Y" "")

 

to

 

(command "_.-OVERKILL" ss "" "_O" 0.0001 "_I" "_A" "_P" "_N" "_T" "_Y" "_E" "_Y" "")

 

 

thanks man for your time and effort

 

(defun c:joinlws ( / *error* clockwise-p LM:Bulge->Arc LM:Arc->Bulge fls fas fle fae *adoc* ss fuzz i lw sp np pp ep sb pb l ll chain d nd dl dll s qaf pea )

 (vl-load-com)

 (defun *error* ( m )
   (if qaf
     (setvar 'qaflags qaf)
   )
   (if pea
     (setvar 'peditaccept pea)
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun clockwise-p ( p1 p p2 )
   (minusp (- (* (car (mapcar '- p1 p)) (cadr (mapcar '- p2 p))) (* (cadr (mapcar '- p1 p)) (car (mapcar '- p2 p)))))
 )

 ;; Bulge to Arc  -  Lee Mac - mod by M.R.
 ;; p1 - start vertex
 ;; p2 - end vertex
 ;; b  - bulge
 ;; Returns: (<center> <start angle> <end angle> <radius>)

 (defun LM:Bulge->Arc ( p1 p2 b / a c r )
     (setq a (* 2 (atan (abs b)))
           r (abs (/ (distance p1 p2) 2 (sin a)))
           c (if (minusp b) (polar p2 (+ (- (/ pi 2) a) (angle p2 p1)) r) (polar p1 (+ (- (/ pi 2) a) (angle p1 p2)) r))
     )
     (if (minusp b)
         (list c (angle c p2) (angle c p1) r)
         (list c (angle c p1) (angle c p2) r)
     )
 )

 ;; Arc to Bulge  -  Lee Mac - mod by M.R.
 ;; c     - center
 ;; a1,a2 - start, end angle
 ;; r     - radius
 ;; lw    - LWPOLYLINE ename
 ;; Returns: (<vertex> <bulge> <vertex>)

 (defun LM:Arc->Bulge ( c a1 a2 r lw / flip )

   (if (vl-member-if '(lambda ( x ) (equal (cdr x) (mapcar '+ '(0.0 0.0) (polar c a1 r)) 1e-6)) (cdr (vl-member-if '(lambda ( x ) (equal (cdr x) (mapcar '+ '(0.0 0.0) (polar c a2 r)) 1e-6)) (entget lw))))
     (setq flip t)
   )

   (list
     (polar c a1 r)
     (if flip
       (- (abs ( (lambda ( a ) (/ (sin a) (cos a)))
                 (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
               )
          )
       )
       (abs ( (lambda ( a ) (/ (sin a) (cos a)))
              (/ (rem (+ pi pi (- a2 a1)) (+ pi pi)) 4.0)
            )
       )
     )
     (polar c a2 r)
   )
 )

 (defun fls ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadr a) (cadr d)) (distance (cadr b) (cadr d))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadddr d) (cadddr x)) (+ (distance (cadddr d) (cadr d)) (distance (cadr d) (cadddr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadddr a) (cadr d)) (distance (cadddr b) (cadr d))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (distance (cadr (car lst1)) (cadr d)) (distance (cadddr (car lst2)) (cadr d)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fas ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr a) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr b) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr a) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr b) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadr (car lst1)) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (cadr (LM:Bulge->Arc (cadddr (car lst2)) (cadddr d) (caddr d))) (caddr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fle ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadr a) (cadddr d)) (distance (cadr b) (cadddr d))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x ) (and (zerop (caddr x)) (equal (distance (cadr d) (cadddr x)) (+ (distance (cadr d) (cadddr d)) (distance (cadddr d) (cadddr x))) 1e-6))) l) '(lambda ( a b ) (< (distance (cadddr a) (cadddr d)) (distance (cadddr b) (cadddr d))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (distance (cadr (car lst1)) (cadr d)) (distance (cadddr (car lst2)) (cadr d)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (defun fae ( d l / lst1 lst2 )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst1 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst1 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr a) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr b) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst1 nil)
   )
   (if (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)
     (if (= (length (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l)) 1)
       (setq lst2 (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l))
       (setq lst2 (vl-sort (vl-remove-if-not '(lambda ( x / *** ) (and (/= (caddr x) 0.0) (equal (distance (cadddr x) (car (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (cadddr ***) 1e-6))) l) '(lambda ( a b ) (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr a) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr b) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi))))))
     )
     (setq lst2 nil)
   )
   (cond
     ( (and lst1 lst2)
       (if (< (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadr (car lst1)) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)) (rem (+ pi pi (- (caddr (LM:Bulge->Arc (cadddr (car lst2)) (cadddr d) (caddr d))) (cadr (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d))))) (+ pi pi)))
         (car lst1)
         (car lst2)
       )
     )
     ( (and lst1 (not lst2))
       (car lst1)
     )
     ( (and (not lst1) lst2)
       (car lst2)
     )
     ( (and (not lst1) (not lst2))
       nil
     )
   )
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (prompt "\nSelect open LWPOLYLINES to process...")
 (setq ss (ssget "_:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>"))))
 (initget 6)
 (setq fuzz (getdist "\nPick or specify fuzz gap distance between adjacent LWPOLYLINES <5e-3> : "))
 (if (null fuzz)
   (setq fuzz 5e-3)
 )
 (repeat (setq i (sslength ss))
   (setq lw (ssname ss (setq i (1- i))))
   (setq sp (vlax-curve-getstartpoint lw))
   (setq np (vlax-curve-getpointatparam lw 1.0))
   (setq pp (vlax-curve-getpointatparam lw (1- (vlax-curve-getendparam lw))))
   (setq ep (vlax-curve-getendpoint lw))
   (setq sb (vla-getbulge (vlax-ename->vla-object lw) 0.0))
   (setq pb (vla-getbulge (vlax-ename->vla-object lw) (1- (vlax-curve-getendparam lw))))
   (setq ll (cons (list (list t sp sb np) (list nil pp pb ep)) ll))
   (setq l (cons (list t sp sb np) l) l (cons (list nil pp pb ep) l))
 )

 (defun chain ( d l )
   (cond
     ( (eq (car d) t)
       (if (zerop (caddr d))
         (setq nd (fls d l))
         (setq nd (fas d l))
       )
     )
     ( (null (car d))
       (if (zerop (caddr d))
         (setq nd (fle d l))
         (setq nd (fae d l))
       )
     )
   )
   (cond
     ( (and nd (not (equal (cdr nd) (cdr d) 1e-) (null dl))
       (setq dl (list d))
       (setq dl (append dl (list nd)))
     )
     ( (and nd (not (equal (cdr nd) (cdr d) 1e-) dl)
       (setq dl (append dl (list nd)))
     )
   )
   (if nd
     (chain nd (vl-remove nd l))
     dl
   )
 )

 (foreach d l
   (foreach pair ll
     (if (or (equal d (car pair) 1e- (equal d (cadr pair) 1e-)
       (progn
         (setq dl (chain d (vl-remove (cadr pair) (vl-remove (car pair) l))))
         (if dl
           (setq dll (cons (list pair dl) dll))
         )
       )
     )
   )
   (setq dl nil)
 )

 (setq s (ssadd))
 (foreach dl dll
   (mapcar '(lambda ( d nd / *** )
     (if (zerop (caddr d))
       (cond
         ( (equal nd (fls d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
           (ssadd (entmakex (list '(0 . "LINE") (cons 10 (if (equal (distance (cadr nd) (cadddr d)) (+ (distance (cadr nd) (cadr d)) (distance (cadr d) (cadddr d))) 1e-6) (cadr nd) (cadddr nd))) (cons 11 (cadr d)))) s)
         )
         ( (equal nd (fle d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
           (ssadd (entmakex (list '(0 . "LINE") (cons 10 (if (equal (distance (cadr nd) (cadr d)) (+ (distance (cadr nd) (cadddr d)) (distance (cadddr d) (cadr d))) 1e-6) (cadr nd) (cadddr nd))) (cons 11 (cadddr d)))) s)
         )
       )
       (cond
         ( (equal nd (fas d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
           (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d)))
           (if (< (distance (cadr d) (cadr nd)) (distance (cadr d) (cadddr nd)))
             (if (not (equal (cadr d) (cadr nd) 1e-6))
               (if (not (clockwise-p (cadr d) (car ***) (cadr nd)))
                 (command "_.ARC" "_non" (cadr d) "_C" "_non" (car ***) "_non" (cadr nd))
                 (command "_.ARC" "_non" (cadr nd) "_C" "_non" (car ***) "_non" (cadr d))
               )
             )
             (if (not (equal (cadr d) (cadddr nd) 1e-6))
               (if (not (clockwise-p (cadr d) (car ***) (cadddr nd)))
                 (command "_.ARC" "_non" (cadr d) "_C" "_non" (car ***) "_non" (cadddr nd))
                 (command "_.ARC" "_non" (cadddr nd) "_C" "_non" (car ***) "_non" (cadr d))
               )
             )
           )
           (ssadd (entlast) s)
         )
         ( (equal nd (fae d (vl-remove (cadar dl) (vl-remove (caar dl) l))) 1e-
           (setq *** (LM:Bulge->Arc (cadr d) (cadddr d) (caddr d)))
           (if (< (distance (cadddr d) (cadr nd)) (distance (cadddr d) (cadddr nd)))
             (if (not (equal (cadddr d) (cadr nd) 1e-6))
               (if (not (clockwise-p (cadddr d) (car ***) (cadr nd)))
                 (command "_.ARC" "_non" (cadddr d) "_C" "_non" (car ***) "_non" (cadr nd))
                 (command "_.ARC" "_non" (cadr nd) "_C" "_non" (car ***) "_non" (cadddr d))
               )
             )
             (if (not (equal (cadddr d) (cadddr nd) 1e-6))
               (if (not (clockwise-p (cadddr d) (car ***) (cadddr nd)))
                 (command "_.ARC" "_non" (cadddr d) "_C" "_non" (car ***) "_non" (cadddr nd))
                 (command "_.ARC" "_non" (cadddr nd) "_C" "_non" (car ***) "_non" (cadddr d))
               )
             )
           )
           (ssadd (entlast) s)
         )
       )
     ))
     (cadr dl)
     (cdr (cadr dl))
   )
 )

 (setq qaf (getvar 'qaflags))
 (setvar 'qaflags 1)
 (command "_.EXPLODE" ss)
 (while (< 0 (getvar 'cmdactive))
   (command "")
 )
 (setq ss (ssget "_P"))
 (repeat (setq i (sslength s))
   (ssadd (ssname s (setq i (1- i))) ss)
 )
 (command "_.-OVERKILL" ss "" "_O" 0.0001 "_I" "_A" "_P" "_N" "_T" "_Y" "_E" "_Y" "")
 (while (< 0 (getvar 'cmdactive))
   (command "")
 )
 (setq pea (getvar 'peditaccept))
 (setvar 'peditaccept 1)
 (command "_.PEDIT" "_M" "_P" "" "_J" "_J" "_E" fuzz)
 (while (< 0 (getvar 'cmdactive))
   (command "")
 )
 (*error* nil)
)

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

You're welcome handasa... Your input is also valuable... It seems that my example is handled fine with you intervention... If only it's applicable for all cases... But never mind it's also good and the way it is now...

 

Regards, M.R.

Link to comment
Share on other sites
marko_ribar Veteran

marko_ribar

Posted
Posted

I've revised my code once again and made it compatible with all AutoCAD versions that have OVERKILL no matter as a command or Express Tool... Also I've excluded creating unnecessary chain lists by recursion as only 2 elements of it are necessity "d" ans "nd" variables for later processing... Also I've excluded (mapcar '(lambda ()...) with (command) function loop as it is buggus in later versions like A2015,2016,... - this causes VVC error, so hopefully with all this fixes, it should be now complete and ready for usage in serious situations...

 

BTW. Do you happen to know when was OVERKILL introduced as real command independent of Express Tools - I've coded lisp that is uses sub function (overkill2012-) for releases prior A2012...

Link to comment
Share on other sites
handasa Community Regular

handasa

Posted
  • Author
Posted
I've revised my code once again and made it compatible with all AutoCAD versions that have OVERKILL no matter as a command or Express Tool... Also I've excluded creating unnecessary chain lists by recursion as only 2 elements of it are necessity "d" ans "nd" variables for later processing... Also I've excluded (mapcar '(lambda ()...) with (command) function loop as it is buggus in later versions like A2015,2016,... - this causes VVC error, so hopefully with all this fixes, it should be now complete and ready for usage in serious situations...

 

BTW. Do you happen to know when was OVERKILL introduced as real command independent of Express Tools - I've coded lisp that is uses sub function (overkill2012-) for releases prior A2012...

 

 

thanks alot , marko_ribar

your work greatly appreciated

Link to comment
Share on other sites
  • 4 years later...
Saqib_theleo Collaborator

Saqib_theleo

Posted
Posted
On 4/22/2016 at 9:38 PM, handasa said:

THIS LISP BY LEE MAC WORK ONLY FOR LINES

  


;; Join Lines  -  Lee Mac
;; Joins collinear lines in a selection, retaining all original properties.

(defun c:joinlines ( / process e i l s x )

   (defun process ( l / x r )
       (if (setq x (car l))
           (progn
               (foreach y (cdr l)
                   (if (vl-every '(lambda ( a ) (apply 'LM:collinear-p (cons a (cdr x)))) (cdr y))
                       (setq x (cons (car x) (LM:furthestapart (append (cdr x) (cdr y)))))
                       (setq r (cons y r))
                   )
               )
               (entmake (append (car x) (mapcar 'cons '(10 11) (cdr x))))
               (process r)
           )
       )
   )
   (if (setq s (ssget "_:L" '((0 . "LINE"))))
       (process
           (repeat (setq i (sslength s))
               (setq e (ssname s (setq i (1- i)))
                     x (entget e)
                     e (entdel e)
                     l (cons (list x (cdr (assoc 10 x)) (cdr (assoc 11 x))) l)
               )
           )
       )
   )
   (princ)
)

;; Furthest Apart  -  Lee Mac
;; Returns the two points furthest apart in a given list

(defun LM:furthestapart ( lst / di1 di2 pt1 rtn )
   (setq di1 0.0)
   (while (setq pt1 (car lst))
       (foreach pt2 (setq lst (cdr lst))
           (if (< di1 (setq di2 (distance pt1 pt2)))
               (setq di1 di2
                     rtn (list pt1 pt2)
               )
           )
       )
   )
   rtn
)

;; Collinear-p  -  Lee Mac
;; Returns T if p1,p2,p3 are collinear

(defun LM:Collinear-p ( p1 p2 p3 )
   (
       (lambda ( a b c )
           (or
               (equal (+ a b) c 1e-
               (equal (+ b c) a 1e-
               (equal (+ c a) b 1e-
           )
       )
       (distance p1 p2) (distance p2 p3) (distance p1 p3)
   )
)

(princ)
 

 

Hello all,  how to make this lisp work for Poly-lines too...

Link to comment
Share on other sites
Saqib_theleo Collaborator

Saqib_theleo

Posted
Posted
6 hours ago, BIGAL said:

Did you read all the posts or stop at 1st.

Hello BIGAL,

thanks for your reply,

yes i read almost all posts and tried also yours "Fmulti" but this was not working for me.

then i tried marko_ribar 's lisp but unfortunately i copied and paste the code which was not working for me. after  your reply i checked again that post 🤭 now i downloaded the file he attached which is working well.

Thank you and marko_ribar.

Link to comment
Share on other sites
BIGAL Grand Master

BIGAL

Posted
Posted (edited)

Good to here its working,  its always a good idea to post a sample dwg before asking for changes as we may have made changes to original post code. I know I have 2 or 3 of these multi fillets.

Edited by BIGAL
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...