How to delete one line from each joint

April 14, 2016

Dear All,

Please find attached drawing.

each joint has double line, because I used lisp routine.

I would like to delete one line, and overkill can not delete because it's not overlapping.

Please suggest how I can delete one line from this, because I have so many drawing like this.

any suggestion will be greatly appreciated.

SUPPLY DUCT.dwg

April 15, 2016

waiting for someone's reply....

April 15, 2016

Good luck. I'm not sure how you would determine which one is correct.

April 15, 2016

You will probably need a lisp, if it is even possible. You can pick by length, but the ends are the same length as the 90° elbow lines so you would have to find a way not to delete those.

I moved your thread to the AutoLISP, Visual LISP & DCL Forum.

April 15, 2016

Perhaps you could go to the source of the problem - your lisp routine. Some positional accuracy of consecutive shapes would be a great help.

April 15, 2016

Hi,

My logical answer for the routine would be:

1. Ssget all the lines

2. Set tolerance for the closest paralel lines (user input)

3. Get each pair with paralel lines below that tolerance value

4. If one of the lines is shorter than the other, delete it, if they have eq lengths delete anyone

But as eldon mentioned, your lisp routine is the problem - you have "overlapping rectangles" with like 0,001 distance between them.

And when I draw a polyline in your drawing it looks modified.

My guess is that you draw a grid of lines, and the lisp overdraws them with these modified polylines?

EDIT:

And ofcourse I have no idea how to get the perpendicular distance between each pair (maybe compare the coordinates of the endpoints and if both lines rotation match?)

April 15, 2016

All I can say is that you could try just (c:weld2d) with supplied adequate fuzz factor, or if you have more time try this steps :

1. start PEDIT, choose "Multiple" option, HIT ENTER few times to convert all entities to LWPOLYLINES...

2. run (c:extshortlwsaddv) - on my PC lasted up to 5 min - provided fuzz 0.1...

3. run (c:plintav-opt) from PLINETOOLS posted here :

http://www.cadtutor.net/forum/showthread.php?67924-Draw-polyline-along-with-2-or-more-adjacent-closed-polylines/page3&p=#25

- on my PC lasted at ab 15-20 min...

4. when finished EXPLODE all LWPOLYLINES to LINES and ARCS...

5. run (c:weld2d) posted here with provided adequate fuzz factor...

- on my PC lasted at ab 30 min - provided fuzz 0.1...

6. start OVERKILL command and supply adequate fuzz factor...

- provided fuzz 0.1

(defun c:weld2d ( / *error* unique dupnum LM:5P-Ellipse detm trp quad LM:defaultprops LM:point->param 3parc *adoc* ucsf ss i ent pepl ppel fuzz allptl n p1 p2 par k dpar pl enx mp ell arc ppl sfa )

 (vl-load-com)

 (defun *error* ( m )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun unique ( l fuzz )
   (if l (cons (car l) (vl-remove-if '(lambda ( p ) (equal p (car l) fuzz)) (unique (cdr l) fuzz))))
 )

 (defun dupnum ( p l n )
   (- n (length (vl-remove p l)))
 )

 ;; 5-Point Ellipse  -  Lee Mac
 ;; Args: p1,p2,p3,p4,p5 - UCS points defining Ellipse
 ;; Returns a list of: ((10 <WCS Center>) (11 <WCS Major Axis Endpoint from Center>) (40 . <Minor/Major Ratio>))

 (defun LM:5P-Ellipse ( p1 p2 p3 p4 p5 / a av b c cf cx cy d e f i m1 m2 rl v x )
     (setq m1
         (trp
             (mapcar
                 (function
                     (lambda ( p )
                         (list
                             (* (car  p) (car  p))
                             (* (car  p) (cadr p))
                             (* (cadr p) (cadr p))
                             (car  p)
                             (cadr p)
                             1.0
                         )
                     )
                 )
                 (list p1 p2 p3 p4 p5)
             )
         )
     )
     (setq i -1.0)
     (repeat 6
         (setq cf (cons (* (setq i (- i)) (detm (trp (append (reverse m2) (cdr m1))))) cf)
               m2 (cons (car m1) m2)
               m1 (cdr m1)
         )
     )
     (mapcar 'set '(f e d c b a) cf) ;; Coefficients of Conic equation ax^2 + bxy + cy^2 + dx + ey + f = 0
     (if (< 0 (setq x (- (* 4.0 a c) (* b b))))
         (progn
             (if (equal 0.0 b 1e- ;; Ellipse parallel to coordinate axes
                 (setq av '((1.0 0.0) (0.0 1.0))) ;; Axis vectors
                 (setq av
                     (mapcar
                         (function
                             (lambda ( v / d )
                                 (setq v (list (/ b 2.0) (- v a)) ;; Eigenvectors
                                       d (distance '(0.0 0.0) v)
                                 )
                                 (mapcar '/ v (list d d))
                             )
                         )
                         (quad 1.0 (- (+ a c)) (- (* a c) (* 0.25 b b))) ;; Eigenvalues
                     )
                 )
             )
             (setq cx (/ (- (* b e) (* 2.0 c d)) x) ;; Ellipse Center
                   cy (/ (- (* b d) (* 2.0 a e)) x)
             )
             ;; For radii, solve intersection of axis vectors with Conic Equation:
             ;; ax^2 + bxy + cy^2 + dx + ey + f = 0  }
             ;; x = cx + vx(t)                       }- solve for t
             ;; y = cy + vy(t)                       }
             (setq rl
                 (mapcar
                     (function
                         (lambda ( v / vv vx vy )
                             (setq vv (mapcar '* v v)
                                   vx (car  v)
                                   vy (cadr v)
                             )
                             (apply 'max
                                 (quad
                                     (+ (* a (car vv)) (* b vx vy) (* c (cadr vv)))
                                     (+ (* 2.0 a cx vx) (* b (+ (* cx vy) (* cy vx))) (* c 2.0 cy vy) (* d vx) (* e vy))
                                     (+ (* a cx cx) (* b cx cy) (* c cy cy) (* d cx) (* e cy) f)
                                 )
                             )
                         )
                     )
                     av
                 )
             )
             (if (apply '> rl)
                 (setq rl (reverse rl)
                       av (reverse av)
                 )
             )
             (list
                 (cons 10 (trans (list cx cy) 1 0)) ;; WCS Ellipse Center
                 (cons 11 (trans (mapcar '(lambda ( v ) (* v (cadr rl))) (cadr av)) 1 0)) ;; WCS Major Axis Endpoint from Center
                 (cons 40 (apply '/ rl)) ;; minor/major ratio
             )
         )
     )
 )

 ;;;***********************************************************************************;;;
 ;;; (detm m) function calculates determinant of square martix                         ;;;
 ;;; Marko Ribar, d.i.a.                                                               ;;;
 ;;; Args: m - nxn matrix                                                              ;;;
 ;;; (detm '((0 1) (1 0)))                                                             ;;;
 ;;; (detm '((1.4 2.1 5.4 6.5) (4.1 9.3 4.5 8.5) (1.2 4.1 6.2 7.5) (4.7 8.5 9.3 0.1))) ;;;
 ;;;***********************************************************************************;;;
 (defun detm ( m / d i j r )

   (defun d ( k n / z )
     (setq k (cdr k))
     (setq k (apply 'mapcar (cons 'list k)))
     (setq z -1)
     (while (<= (setq z (1+ z)) (length k))
       (if (eq z n)
         (setq k (cdr k))
         (setq k (reverse (cons (car k) (reverse (cdr k)))))
       )
     )
     (setq k (apply 'mapcar (cons 'list k)))
     (if (= (length k) 1) (caar k) k)
   )

   (if (not (eq (length m) 1))
     (progn
       (setq i -1)
       (setq j -1)
       (setq r 0)
       (foreach e (car m)
         (setq i (1+ i))
         (setq j (* j (- 1)))
         (setq r (+ r (* j e (if (listp (d m i)) (detm (d m i)) (d m i)))))
       )
       r
     )
     (caar m)
   )
 )

 ;; Matrix Transpose  -  Doug Wilson
 ;; Args: m - nxn matrix

 (defun trp ( m )
     (apply 'mapcar (cons 'list m))
 )

 ;; Quadratic Solution  -  Lee Mac
 ;; Args: a,b,c - coefficients of ax^2 + bx + c = 0

 (defun quad ( a b c / d r )
     (if (<= 0 (setq d (- (* b b) (* 4.0 a c))))
         (progn
             (setq r (sqrt d))
             (list (/ (+ (- b) r) (* 2.0 a)) (/ (- (- b) r) (* 2.0 a)))
         )
     )
 )

 ;; Default Properties  -  Lee Mac
 ;; Returns a list of DXF properties for the supplied DXF data,
 ;; substituting default values for absent DXF groups

 (defun LM:defaultprops ( enx )
     (vl-remove nil
         (mapcar '(lambda ( x ) (cond ((assoc (car x) enx)) ((not (assoc (car x) enx)) nil) ( x )))
            '(
                 (006 . "BYLAYER")
                 (008 . "0")
                 (039 . 0.0)
                 (048 . 1.0)
                 (062 . 256)
                 (370 . -1)
                 (420 . 16777215)
             )
         )
     )
 )

 ;; Point -> Ellipse Parameter  -  Lee Mac
 ;; Returns the ellipse parameter for the given point
 ;; dxf  -  Ellipse DXF data (DXF groups 10, 11, 40, 210)
 ;; pnt  -  WCS Point on Ellipse
 ;; Uses relationship: ratio*tan(param) = tan(angle)

 (defun LM:point->param ( dxf pnt / ang ocs )
     (setq ocs (cdr (assoc 210 dxf))
           ang (- (angle (trans (cdr (assoc 10 dxf)) 0 ocs) (trans pnt 0 ocs))
                  (angle '(0.0 0.0) (trans (cdr (assoc 11 dxf)) 0 ocs))
               )
     )
     (atan (sin ang) (* (cdr (assoc 40 dxf)) (cos ang)))
 )

 (defun 3parc ( p1 p2 p3 / mid clockwise-p ang1 ang2 cen eang mid1 mid2 rad sang )

   (defun mid ( p1 p2 )
     (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2)
   )

   (defun clockwise-p ( p1 p2 p3 ) ; Gile
     (< (sin (- (angle p1 p3) (angle p1 p2))) -1e-14)
   )

   (setq ang1 (angle p1 p2) ang2 (angle p2 p3)
         mid1 (mid p1 p2)   mid2 (mid p2 p3)
   
         cen  (inters mid1 (polar mid1 (+ ang1 (/ pi 2.)) 1.)
                      mid2 (polar mid2 (+ ang2 (/ pi 2.)) 1.) nil)
         
         rad  (distance cen p1)
   )

   (if (clockwise-p p1 p2 p3)
     (setq sAng (angle cen p3)
           eAng (angle cen p1)
     )
     (setq sAng (angle cen p1)
           eAng (angle cen p3)
     )
   )

   (list 
     (cons 10 cen)
     (cons 40 rad)
     (cons 50 sAng)
     (cons 51 eAng)
   )
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (if (= (getvar 'worlducs) 0)
   (progn
     (command "_.UCS" "_W")
     (setq ucsf t)
   )
 )
 (prompt "\nSelect 2d curves placed in WCS and on unlocked layer(s)...")
 (setq ss (ssget "_:L"))
 (repeat (setq i (sslength ss))
   (setq ent (ssname ss (setq i (1- i))))
   (if (or (not (and (vlax-curve-isplanar ent) (equal (caddr (vlax-curve-getstartpoint ent)) 0.0 1e-6))) (and (wcmatch (cdr (assoc 0 (entget ent))) "SPLINE,ELLIPSE") (equal (vlax-curve-getstartpoint ent) (vlax-curve-getendpoint ent) 1e-6)))
     (ssdel ent ss)
   )
 )
 (repeat (setq i (sslength ss))
   (setq ent (ssname ss (setq i (1- i))))
   (cond
     ( (wcmatch (cdr (assoc 0 (entget ent))) "SPLINE,LINE,ARC,ELLIPSE,POLYLINE,LWPOLYLINE")
       (cond
         ( (and (= (cdr (assoc 0 (entget ent))) "POLYLINE") (not (or (= (cdr (assoc 70 (entget ent))) 0) (= (cdr (assoc 70 (entget ent))) 128) (= (cdr (assoc 70 (entget ent))) 1) (= (cdr (assoc 70 (entget ent))) 129))))
           (setq pepl (cons (list (vlax-curve-getstartpoint ent) ent (vlax-curve-getendpoint ent)) pepl))
         )
         ( (and (= (cdr (assoc 0 (entget ent))) "POLYLINE") (/= (cdr (assoc 90 (entget ent))) 2))
           (command "_.CONVERTPOLY" "_L" ent "")
           (setq ppel (cons (list (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget ent))) ent) ppel))
           (command "_.UNDO" "1")
         )
         ( (and (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE") (/= (cdr (assoc 90 (entget ent))) 2))
           (setq ppel (cons (list (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget ent))) ent) ppel))
         )
         ( t
           (setq pepl (cons (list (vlax-curve-getstartpoint ent) ent (vlax-curve-getendpoint ent)) pepl))
         )
       )
     )
   )
 )
 (setq fuzz 0.11)
 (while (> fuzz 0.1)
   (initget 6)
   (setq fuzz (getdist "\nPick or specify fuzz distance <1e-3> - should not be greater than 0.1 : "))
   (if (null fuzz)
     (setq fuzz 1e-3)
   )
 )
 (foreach pep pepl
   (setq allptl (cons (car pep) allptl) allptl (cons (last pep) allptl))
 )
 (foreach ppe ppel
   (setq allptl (append (mapcar '(lambda ( p ) (list (car p) (cadr p) 0.0)) (car ppe)) allptl))
 )
 (setq n (length allptl))
 (setq allptl (vl-sort allptl '(lambda ( a b ) (> (dupnum a allptl n) (dupnum b allptl n)))))
 (setq allptl (unique allptl (/ fuzz 2.5)))
 (foreach pep pepl
   (setq p1 (car pep) ent (cadr pep) p2 (caddr pep))
   (setq p1 (car (vl-member-if '(lambda ( p ) (equal p1 p fuzz)) allptl)))
   (setq p2 (car (vl-member-if '(lambda ( p ) (equal p2 p fuzz)) allptl)))
   (if (null p1)
     (setq p1 (car pep))
   )
   (if (null p2)
     (setq p2 (caddr pep))
   )
   (cond
     ( (= (cdr (assoc 0 (entget ent))) "ELLIPSE")
       (setq pl nil)
       (setq par (vlax-curve-getstartparam ent))
       (setq k -1 dpar (/ (- (vlax-curve-getendparam ent) par) 5.00000001))
       (repeat 5
         (setq pl (cons (vlax-curve-getpointatparam ent (+ par (* (setq k (1+ k)) dpar))) pl))
       )
       (setq pl (reverse pl))
       (if (equal p1 p2 1e-6)
         (setq p1 (car pep) p2 (caddr pep))
       )
       (setq pl (reverse (cons p2 (cdr (reverse (cons p1 (cdr pl)))))))
       (setq enx (entget ent))
       (entmake
         (append
          '(
             (0 . "ELLIPSE")
             (100 . "AcDbEntity")
             (100 . "AcDbEllipse")
           )
           (LM:defaultprops enx)
           (setq ell (LM:5P-Ellipse pl))
           (list
             (cons 41 (LM:point->param (cons (list 210 0.0 0.0 1.0) ell) p1))
             (cons 42 (LM:point->param (cons (list 210 0.0 0.0 1.0) ell) p2))
           )
           (list (list 210 0.0 0.0 1.0))
         )
       )
       (entdel ent)
     )
     ( (= (cdr (assoc 0 (entget ent))) "ARC")
       (setq mp (vlax-curve-getpointatparam ent (/ (+ (vlax-curve-getstartparam ent) (vlax-curve-getendparam ent)) 2.0)))
       (setq enx (entget ent))
       (if (equal p1 p2 1e-6)
         (setq p1 (car pep) p2 (caddr pep))
       )
       (entmake
         (append
          '(
             (0 . "ARC")
             (100 . "AcDbEntity")
             (100 . "AcDbCircle")
           )
           (LM:defaultprops enx)
           (list (car (setq arc (3parc p1 mp p2))) (cadr arc))
           (list (cons 100 "AcDbArc"))
           (list (caddr arc) (cadddr arc))
           (list (list 210 0.0 0.0 1.0))
         )
       )
       (entdel ent)
     )
     ( (= (cdr (assoc 0 (entget ent))) "LINE")
       (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget ent)) (entget ent))))))
       (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (entget ent)) (entget ent))))))
     )
     ( (= (cdr (assoc 0 (entget ent))) "POLYLINE")
       (if (= (cdr (assoc 100 (reverse (entget ent)))) "AcDb2dPolyline")
         (progn
           (setq sfa (vlax-make-safearray vlax-vbdouble (cons 1 (length (safearray-value (variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))))))
           (vlax-safearray-fill sfa (list (car p1) (cadr p1) (car p2) (cadr p2)))
           (vla-put-coordinates (vlax-ename->vla-object ent) (vlax-make-variant sfa))
         )
         (progn
           (setq sfa (vlax-make-safearray vlax-vbdouble (cons 1 (length (safearray-value (variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))))))
           (vlax-safearray-fill sfa (list (car p1) (cadr p1) 0.0 (car p2) (cadr p2) 0.0))
           (vla-put-coordinates (vlax-ename->vla-object ent) (vlax-make-variant sfa))
         )
       )
       (vla-update (vlax-ename->vla-object ent))
     )
     ( (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
       (entupd (cdr (assoc -1 (entmod (subst (list 10 (car p1) (cadr p1)) (assoc 10 (entget ent)) (entget ent))))))
       (entupd (cdr (assoc -1 (entmod (subst (list 10 (car p2) (cadr p2)) (assoc 10 (reverse (entget ent))) (entget ent))))))
     )
     ( (= (cdr (assoc 0 (entget ent))) "SPLINE")
       (if (assoc 10 (entget ent))
         (progn
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p1) (assoc 10 (entget ent)) (entget ent))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 10 p2) (assoc 10 (reverse (entget ent))) (entget ent))))))
         )
         (progn
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p1) (assoc 11 (entget ent)) (entget ent))))))
           (entupd (cdr (assoc -1 (entmod (subst (cons 11 p2) (assoc 11 (reverse (entget ent))) (entget ent))))))
         )
       )
     )
   )
 )
 (foreach ppe ppel
   (setq pl (car ppe) ent (cadr ppe) ppl nil)
   (foreach p pl
     (setq ppl (cons (if (car (vl-member-if '(lambda ( x ) (equal (list (car p) (cadr p) 0.0) x fuzz)) allptl)) (car (vl-member-if '(lambda ( x ) (equal (list (car p) (cadr p) 0.0) x fuzz)) allptl)) p) ppl))
   )
   (setq ppl (reverse ppl))
   (cond
     ( (= (cdr (assoc 0 (entget ent))) "POLYLINE")
       (if (= (cdr (assoc 100 (reverse (entget ent)))) "AcDb2dPolyline")
         (progn
           (setq sfa (vlax-make-safearray vlax-vbdouble (cons 1 (length (safearray-value (variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))))))
           (vlax-safearray-fill sfa (vl-remove 0.0 (apply 'append ppl)))
           (vla-put-coordinates (vlax-ename->vla-object ent) (vlax-make-variant sfa))
         )
         (progn
           (setq sfa (vlax-make-safearray vlax-vbdouble (cons 1 (length (safearray-value (variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))))))
           (vlax-safearray-fill sfa (apply 'append ppl))
           (vla-put-coordinates (vlax-ename->vla-object ent) (vlax-make-variant sfa))
         )
       )
       (vla-update (vlax-ename->vla-object ent))
     )
     ( (= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
       (setq sfa (vlax-make-safearray vlax-vbdouble (cons 1 (length (safearray-value (variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))))))
       (vlax-safearray-fill sfa (vl-remove 0.0 (apply 'append ppl)))
       (vla-put-coordinates (vlax-ename->vla-object ent) (vlax-make-variant sfa))
       (vla-update (vlax-ename->vla-object ent))
     )
   )
 )
 (*error* nil)
)

HTH, M.R.

Edited April 18, 2016 by marko_ribar
code changed...

April 16, 2016

Hi there, thank to your wired request I figured out that my plintav.lsp is very slow and that it needed optimization... So finally I've modified it and my new version is called "plintav-opt.lsp"... I've lowered execution time to acceptable 15-20 min with your example and I think that that's very good result... I'll attach my attempts to correct your DWG - DWGs are stored in archive and sorted by date/time... So here is my "plintav-opt.lsp"

;;; plintav-opt - adds vertices at intersection of plines and cleans double vertices - doesn't deal with welding and adding new vertices at start/end points of overlapping plines ;;;

(defun c:plintav-opt ( / *error* *adoc* intersobj1obj2 LM:Unique AT:GetVertices _reml member-fuzz add_vtx
                    ss sslpl sshpl i ent n ent1 ent1l ll ur bbl ss-ent1 k ent2 intpts intptsall pl plpts par pickb )

 (vl-load-com)

 (defun *error* ( m )
   (if pickb
     (setvar 'pickbox pickb)
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
   (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
   (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
   (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendNone))))))
   (if (vl-catch-all-error-p coords)
     (setq ptlst nil)
     (repeat (/ (length coords) 3)
       (setq pt (list (car coords) (cadr coords) (caddr coords)))
       (setq ptlst (cons pt ptlst))
       (setq coords (cdddr coords))
     )
   )
   ptlst
 )  

 (defun LM:Unique ( lst )
   (if lst (cons (car lst) (LM:Unique (vl-remove (car lst) (cdr lst)))))
 )

 (defun AT:GetVertices ( e / p l )
   (LM:Unique
     (if e
       (if (eq (setq p (vlax-curve-getEndParam e)) (fix p))
         (repeat (setq p (1+ (fix p)))
           (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l))
         )
         (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e))
       )
     )
   )
 )

 (defun _reml ( l1 l2 / a n ls )
   (while 
     (setq n nil 
           a (car l2)
     )
     (while (and l1 (null n))
       (if (equal a (car l1) 1e-
         (setq l1 (cdr l1) 
               n t
         )
         (setq ls (append ls (list (car l1)))
               l1 (cdr l1)
         )
       )
     )
     (setq l2 (cdr l2))
   )
   (append ls l1)
 )

 (defun member-fuzz ( expr lst fuzz )
   (while (and lst (not (equal (car lst) expr fuzz)))
     (setq lst (cdr lst))
   )
   lst
 )

 (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
     (vla-GetWidth obj (fix add_pt) 'sw 'ew)
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
     (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
     (vla-update obj)
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (command "_.ZOOM" "_E")
 (command "_.ZOOM" "0.5XP")
 (setq ss (ssget "_:L" (list '(0 . "*POLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 1) '(70 . 128) '(70 . 129) '(-4 . "or>") (cons 410 (if (= 1 (getvar 'cvport)) (getvar 'ctab) "Model")))))
 (setq sslpl (ssadd) sshpl (ssadd))
 (setq i -1)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (if (eq (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
     (ssadd ent sslpl)
   )
   (if (eq (cdr (assoc 0 (entget ent))) "POLYLINE")
     (ssadd ent sshpl)
   )
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "l" ent "")
   (entupd ent)
   (vla-update (vlax-ename->vla-object ent))
   (ssadd ent sslpl)
 )
 (setq ll (car (acet-geom-ss-extents-accurate ss)) ur (cadr (acet-geom-ss-extents-accurate ss)))
 (setq bbl (list ll (list (car ur) (cadr ll)) ur (list (car ll) (cadr ur))))
 (repeat (setq n (sslength ss))
   (setq ent1 (ssname ss (setq n (1- n))))
   (setq ent1l (cons ent1 ent1l))
   (vla-getboundingbox (vlax-ename->vla-object ent1) 'll 'ur)
   (mapcar 'set '(ll ur) (mapcar 'vlax-safearray->list (list ll ur)))
   (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point ll) (vlax-3d-point ur))
   (setq ss-ent1 (ssget "_CP" bbl '((0 . "LWPOLYLINE"))))
   (vla-zoomprevious (vlax-get-acad-object))
   (foreach ent ent1l
     (if (ssmemb ent ss-ent1)
       (ssdel ent ss-ent1)
     )
   )
   (repeat (setq k (sslength ss-ent1))
     (setq ent2 (ssname ss-ent1 (setq k (1- k))))
     (setq intpts (intersobj1obj2 ent1 ent2))
     (setq intptsall (append intpts intptsall))
   )
 )
 (setq intptsall (LM:Unique intptsall))
 (setq pickb (getvar 'pickbox))
 (setvar 'pickbox 0)
 (while (setq pt (car intptsall))
   (foreach pl (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "_C" pt pt '((0 . "LWPOLYLINE"))))))
     (setq plpts (AT:GetVertices pl))
     (setq intptsall (_reml intptsall plpts))
     (if 
       (and
         (not (member-fuzz pt plpts 1e-6))
         (setq par (vlax-curve-getparamatpoint pl pt))
       )
       (add_vtx (vlax-ename->vla-object pl) par pl)        
     )
   )
   (setq intptsall (vl-remove pt intptsall))
 )
 (setq i -1)
 (while (setq ent (ssname sshpl (setq i (1+ i))))
   (command "_.convertpoly" "h" ent "")
 )
 (command "_.ZOOM" "_P")
 (command "_.ZOOM" "_P")
 (*error* nil)
)

BTW. With DWGs like your example, you'll probably need at least 1 hour for each to make it more accurate and like I said you'll still have bad portions like you've marked, but some of them will be solved...

HTH, M.R.

Edited April 17, 2016 by marko_ribar

April 16, 2016

I've changed (c:weld2d) to avoid error termination on example you provided...

Here is my last code - it should be run firstly... So everything is in reverse order from what is posted... I'll change explanation in first my reply...

(defun c:extshortlwsaddv ( / *error* intersobj1obj2 add_vtx *adoc* ucsf ss i ent fuzz ll ur bbl ent1 ent2 ss-ent1 k intpts )

 (vl-load-com)

 (defun *error* ( m )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (vla-endundomark *adoc*)
   (if m
     (prompt m)
   )
   (princ)
 )

 (defun intersobj1obj2 ( obj1 obj2 / coords pt ptlst )
   (if (eq (type obj1) 'ENAME) (setq obj1 (vlax-ename->vla-object obj1)))
   (if (eq (type obj2) 'ENAME) (setq obj2 (vlax-ename->vla-object obj2)))
   (setq coords (vl-catch-all-apply 'vlax-safearray->list (list (vl-catch-all-apply 'vlax-variant-value (list (vla-intersectwith obj1 obj2 AcExtendBoth))))))
   (if (vl-catch-all-error-p coords)
     (setq ptlst nil)
     (repeat (/ (length coords) 3)
       (setq pt (list (car coords) (cadr coords) (caddr coords)))
       (setq ptlst (cons pt ptlst))
       (setq coords (cdddr coords))
     )
   )
   ptlst
 )

 (defun add_vtx ( obj add_pt ent_name / bulg sw ew )
     (vla-GetWidth obj (fix add_pt) 'sw 'ew)
     (vla-addVertex
         obj
         (1+ (fix add_pt))
         (vlax-make-variant
             (vlax-safearray-fill
                 (vlax-make-safearray vlax-vbdouble (cons 0 1))
                     (list
                         (car (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                         (cadr (trans (vlax-curve-getpointatparam obj add_pt) 0 ent_name))
                     )
             )
         )
     )
     (setq bulg (vla-GetBulge obj (fix add_pt)))
     (vla-SetBulge obj
         (fix add_pt)
         (/
             (sin (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
             (cos (/ (* 4 (atan bulg) (- add_pt (fix add_pt))) 4))
         )
     )
     (vla-SetBulge obj
         (1+ (fix add_pt))
         (/
             (sin (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
             (cos (/ (* 4 (atan bulg) (- (1+ (fix add_pt)) add_pt)) 4))
         )
     )
     (vla-SetWidth obj (fix add_pt) sw (+ sw (* (- ew sw) (- add_pt (fix add_pt)))))
     (vla-SetWidth obj (1+ (fix add_pt)) (+ sw (* (- ew sw) (- add_pt (fix add_pt)))) ew)
     (vla-update obj)
 )

 (vla-startundomark (setq *adoc* (vla-get-activedocument (vlax-get-acad-object))))
 (if (= (getvar 'worlducs) 0)
   (progn
     (command "_.UCS" "_W")
     (setq ucsf t)
   )
 )
 (setq ss (ssget "_:L" '((0 . "LWPOLYLINE"))))
 (repeat (setq i (sslength ss))
   (setq ent (ssname ss (setq i (1- i))))
   (if (not (and (vlax-curve-isplanar ent) (equal (caddr (vlax-curve-getstartpoint ent)) 0.0 1e-6)))
     (ssdel ent ss)
   )
 )
 (setq fuzz 0.11)
 (while (> fuzz 0.1)
   (initget 6)
   (setq fuzz (getdist "\nPick or specify fuzz distance <1e-2> - should not be greater than 0.1 : "))
   (if (null fuzz)
     (setq fuzz 1e-2)
   )
 )
 (setq ll (car (acet-geom-ss-extents-accurate ss)) ur (cadr (acet-geom-ss-extents-accurate ss)))
 (setq bbl (list ll (list (car ur) (cadr ll)) ur (list (car ll) (cadr ur))))
 (repeat (setq i (sslength ss))
   (setq ent1 (ssname ss (setq i (1- i))))
   (vla-getboundingbox (vlax-ename->vla-object ent1) 'll 'ur)
   (mapcar 'set '(ll ur) (mapcar 'vlax-safearray->list (list ll ur)))
   (vla-zoomwindow (vlax-get-acad-object) (vlax-3d-point ll) (vlax-3d-point ur))
   (setq ss-ent1 (ssget "_CP" bbl '((0 . "LWPOLYLINE"))))
   (vla-zoomprevious (vlax-get-acad-object))
   (ssdel ent1 ss-ent1)
   (repeat (setq k (sslength ss-ent1))
     (setq ent2 (ssname ss-ent1 (setq k (1- k))))
     (setq intpts (intersobj1obj2 ent1 ent2))
     (if intpts
       (foreach pt intpts
         (if
           (or
             (and
               (vlax-curve-getparamatpoint ent1 pt)
               (not (vlax-curve-getparamatpoint ent2 pt))
             )
             (and
               (not (vlax-curve-getparamatpoint ent1 pt))
               (vlax-curve-getparamatpoint ent2 pt)
             )
           )
           (cond
             ( (and (vlax-curve-getparamatpoint ent1 pt) (not (equal (vlax-curve-getparamatpoint ent1 pt) (vlax-curve-getstartparam ent1) 1e-5)) (not (equal (vlax-curve-getparamatpoint ent1 pt) (vlax-curve-getendparam ent1) 1e-5)) (or (<= (distance (vlax-curve-getstartpoint ent2) pt) fuzz) (<= (distance (vlax-curve-getendpoint ent2) pt) fuzz)))
               (add_vtx (vlax-ename->vla-object ent1) (vlax-curve-getparamatpoint ent1 pt) ent1)
               (cond
                 ( (<= (distance (vlax-curve-getstartpoint ent2) pt) fuzz)
                   (entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car pt) (cadr pt))) (assoc 10 (entget ent2)) (entget ent2))))))
                 )
                 ( (<= (distance (vlax-curve-getendpoint ent2) pt) fuzz)
                   (entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car pt) (cadr pt))) (assoc 10 (reverse (entget ent2))) (entget ent2))))))
                 )
               )
             )
             ( (and (vlax-curve-getparamatpoint ent2 pt) (not (equal (vlax-curve-getparamatpoint ent2 pt) (vlax-curve-getstartparam ent2) 1e-5)) (not (equal (vlax-curve-getparamatpoint ent2 pt) (vlax-curve-getendparam ent2) 1e-5)) (or (<= (distance (vlax-curve-getstartpoint ent1) pt) fuzz) (<= (distance (vlax-curve-getendpoint ent1) pt) fuzz)))
               (add_vtx (vlax-ename->vla-object ent2) (vlax-curve-getparamatpoint ent2 pt) ent2)
               (cond
                 ( (<= (distance (vlax-curve-getstartpoint ent1) pt) fuzz)
                   (entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car pt) (cadr pt))) (assoc 10 (entget ent1)) (entget ent1))))))
                 )
                 ( (<= (distance (vlax-curve-getendpoint ent1) pt) fuzz)
                   (entupd (cdr (assoc -1 (entmod (subst (cons 10 (list (car pt) (cadr pt))) (assoc 10 (reverse (entget ent1))) (entget ent1))))))
                 )
               )
             )
           )
         )
       )
     )
   )
 )
 (*error* nil)
)

Also in attachment is final DWG after execution of routines... Should be corrected in the most portions...

M.R.

Edited April 17, 2016 by marko_ribar

April 17, 2016

Newest explanation provided in post #7...

Regards, M.R.

SUPPLY DUCT.zip

Edited April 17, 2016 by marko_ribar

April 17, 2016

Dear, Marko

I greatly appreciate and thankful for your initiative and efforts to solve the issue.

I tried all above your mentioned steps it's consuming more time, because I am not that much master to do such type of thing,

if you want to favor me, shall I attach the Lisp routine, which I am using to draw the Duct.

Please try to modify Lisp routine to come each joint line one above another (Overlapping) so I can use Overkill command, so it will be very easy to delete overlapped lines.

Many many thanks to you.

April 18, 2016

I'd stop using that LISP entirely. Along with the troubles you are having, there are other issues. You may have different standards but over here the radii are too small. Elbows that sharp affect performance of the system. Transitions are not consistent. The angle vary and are not standard. You are going through too much trouble to fix a poorly drawn system. Sorry to be so blunt but garbage in/garbage out is what you have here.

Sign In

How to delete one line from each joint

Recommended Posts

CAD USER

CAD USER

RobDraw

SLW210

eldon

Grrr

marko_ribar

marko_ribar

marko_ribar

marko_ribar

CAD USER

RobDraw

Join the conversation

Tutorials

Forums

Activity