Copy polyline segment that crosses another line

[Steven P]

Happy Friday everyone

 

Before I go off and spend time working this out, does anyone have this that they can share?

 

I have a polyline (1) crossing another (2), the polylines are at different elevations. What I want (to fix another LISP) is to copy the segment of the crossing polyline (1) which crosses the other (2)

 

 

Sounds like this is the type of thing that someone will have somewhere, thanks in advance

 

[mhupp]

Don't have anything myself but prob do something like

 

(ssget "_F" cords of poly 1 ((0 . poly)))  to find poly 2 fence only uses x and y so will select things on different elevations.

 

find closest point on ply1 to ply2 ???  (only crossing?)    or just select poly1 mouse click near location?

 

use point to find vertex # on ply1

(setq v (fix (vlax-curve-getParamAtPoint poly1 (vlax-curve-getClosestPointTo poly1 pt))))

 

use vertex to find the points on either side

(setq StrPt (vlax-Curve-GetPointAtParam poly1 v))
(setq EndPt (vlax-Curve-GetPointAtParam poly1 (1+ v)))

 

entmake

(entmake (list '(0 . "LINE") (cons 10 StrPT) (cons 11 EndPt)))

 

 

--Edit

maybe select both polylines use intes on cords with mapcar to find point?

 

--Edit2

https://www.theswamp.org/index.php?PHPSESSID=fa96fb880a6e370b50e4902edc7e1abf&topic=49865.msg550384#msg550384

Edited December 16, 2022 by mhupp

[mhupp]

Here is a manual way using code above. line is created on current layer

 

;;----------------------------------------------------------------------;;
;; Make a Copy of Poly Segment.
(defun C:CopySegment (/ x poly v Strpt Endpt )
  (while (setq x (entsel "\nSelect Polyline Segment to Copy: "))
    (setq poly (vlax-ename->vla-object (car x)))
    (setq v (fix (vlax-curve-getParamAtPoint poly (vlax-curve-getClosestPointTo poly (cadr x)))))
    (setq StrPt (vlax-Curve-GetPointAtParam poly v))
    (setq EndPt (vlax-Curve-GetPointAtParam poly (1+ v)))
    (entmake (list '(0 . "LINE") (cons 10 StrPT) (cons 11 EndPt)))
  )
  (princ)
)

 

--Edit

Only works with straight lines.

 

Edited December 16, 2022 by mhupp

[Steven P]

Thanks, I'll try that tomorrow, been going round in circles finding a nice way and was just about to give up, explode the polylines, find the intersection, get points, undo the exploding, draw a line between the points

[mhupp]

Use Visual lisp command to explode things. It keeps the original and makes copies of the individual entities. So as you step though them to test just delete as you go. Then there isn't a need to undo. This method works with blocks, polylines, hatches, mtext basically anything you can explode into sub entities.

 

(setq poly (vlax-invoke (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline:"))) 'explode))
(setq poly2 (vlax-ename->vla-object (car (entsel "\nSelect 2nd Polyline:")))
(foreach obj poly ;gives a list of all entities created in vla-object name.
  (setq pt (vlax-invoke obj 'intersectWith poly2 acextendnone)) ;dont know if this works with diff elevation
  ;or make a list of points
  (vla-delete obj) ;after test delete entity
)

 

-Edit

Over thinking it again. I was like why delete very thing to come back and use entmake!?!?

This will work with arc's too.

example

 

;;----------------------------------------------------------------------;;
;; Make a Copy of Poly Segment if intersect
(defun C:CPS (/ e p c l)
  (setq e (vla-get-elevation (setq p (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline: "))))))
  (setq c (vla-copy (vlax-ename->vla-object (car (entsel "\nSelect 2nd Polyline: ")))))
  (vla-put-elevation c e) ;move it to same eleveation as first poly
  (foreach obj (vlax-invoke p 'explode)
    (if (vlax-invoke obj 'intersectWith c acextendnone)
      (vla-put-Color obj 1) ;or change layer, or nothing (progn)
      (vla-delete obj) ;delete object if intersection not found
    )
  )
  (vla-delete c) ;delete copy polyline
  (princ)
)

 

 

Edited December 17, 2022 by mhupp

[Steven P]

Perfect! (mostly - are we ever happy?)

 

Last line (vla-delete check) should be (vla-delete c) , just a typo

 

 

Am breaking my own rules and looking at CAD on a Saturday, whoops, so on Monday I think I am going alter your code slightly, if I move the vla-get-elevation, vla-put-elevation into the foreach to do that for each segment individually that should cover the case where a polyline elevation changes along it length

 

Something like:

 

(defun C:CPS (/ e p c l)
;;  (setq e (vla-get-elevation (setq p (vlax-ename->vla-object (car (entsel "\nSelect Main Polyline: "))))))

(setq p (vlax-ename->vla-object (car (entsel "\nSelect Crossing Polyline: "))))

  (setq c (vla-copy (vlax-ename->vla-object (car (entsel "\nSelect Route Polyline: ")))))
;;  (vla-put-elevation c e) ;move it to same eleveation as first poly
  (foreach obj (vlax-invoke p 'explode)

(setq e (vla-get-elevation obj))
(vla-put-elevation c e) ;move it to same eleveation as first poly

    (if (vlax-invoke obj 'intersectWith c acextendnone)
      (vla-put-Color obj 1) ;or change layer, or nothing (progn)
      (vla-delete obj) ;delete object if intersection not found
    )
  )
  (vla-delete c) ;delete copy polyline
  (princ)
)

 

 

Very quickly though gives the error "; error: ActiveX Server returned the error: unknown name: Elevation" - so 90% there will do the rest next week (unless i get bored later today)

[mhupp]

5 hours ago, Steven P said:

Last line (vla-delete check) should be (vla-delete c) , just a typo

Whoops hate naming variables. half way thought i was like this is the check polyline but its also the copied lets jut name it c

 

5 hours ago, Steven P said:

Very quickly though gives the error "; error: ActiveX Server returned the error: unknown name: Elevation" - so 90% there will do the rest next week (unless i get bored later today)

 

I prob should have put 2 and 2 together there. Your are using 3d poly lines. Those don't have elevation because they have x y z coords.

So that code won't work.

 

What your probably going to have to do now is

Select Crossing 3d polyline

get bounding box info for min max z elevation.

select Route polyline

convert it to 2d

set to min or beloew elevation of crossing polyline

make a 3d face/region to or above max elevaton

 

edit the following to find points of crossing

https://www.cadtutor.net/forum/topic/75018-get-points-on-a-3d-curve-with-the-same-z-coordinate-corresponding/?do=findComment&comment=593874

 

Use points found in the original code in the manual selection copy segments.

 

 

 

[Steven P]

This will do for a Saturday night for me:

 

Pretty much what you did MHUPP.

 

I set the route elevation to a nominal 0 - it makes things easier later (I should be drawing it at 0 elevation anyway for the other half of the LISP to work), fixes 3d polyline and elevations there

In the for each loop I went entmod to each segment / object to move to 0 elevation, check if it crosses the route, and if so put it back to it's elevation else delete as you did.

 

Thanks - will try to break this on Monday now.... 

 

 

 

(defun C:CPS (/ p c obj pent panda pendb ed) ;; polylines only
  (setq p (vlax-ename->vla-object (car (entsel "\nSelect Crossing: "))))
  (setq c (vla-copy (vlax-ename->vla-object (car (entsel "\nSelect Route: ")))))
  (vla-put-elevation c 0) ;move route copy to zero elevation

  (foreach obj (vlax-invoke p 'explode)
    (setq pent (vlax-vla-object->ename obj)) ; get object entity
    (setq panda (cdr (assoc 10 (entget pent)))) ; end A
    (if (= (assoc 11 (entget pent)) nil)() ; end B if applicable
      (setq pendb (cdr (assoc 11 (entget pent))))
    )
    (setq ed (entget pent))
    (setq ed (subst (cons 10 (mapcar '* '(1 1 0) panda)) (assoc 10 ed) ed ))
    (if (= nil pendb)()
      (setq ed (subst (cons 11 (mapcar '* '(1 1 0) pendb)) (assoc 11 ed) ed ))
    )
    (entmod ed) ;move segment to elvation 0

    (if (vlax-invoke obj 'intersectWith c acextendnone)
      (progn
        (setq ed (entget pent)) ;; can probably delete this line
        (setq ed (subst (cons 10 panda) (assoc 10 ed) ed ))
        (if (= nil pendb)()
          (setq ed (subst (cons 11 pendb) (assoc 11 ed) ed ))
        )
        (entmod ed) ;return segment to elevations
        (vla-put-Color obj 1) ;or change layer, or nothing (progn)
      ) ; end progn
      (vla-delete obj) ;delete object if intersection not found
    ) ; end if
  ) ; end for each
  (vla-delete c) ;delete copy polyline
  (princ)
)

 

[ronjonp]

You should post a drawing of what you're working with. If there are no curves in your linework then use INTERS as @mhupp suggested.

 

Here's a quick example. It does not draw a line 'yet' but identifies both straight segments of intersections. Does not see self intersections.

(defun c:foo (/ _f _foo a j pts r s z)
  (defun _f (p) (list (car p) (cadr p)))
  (defun _foo (o / p r)
    (setq p (vlax-get o 'coordinates))
    (if	(= "AcDbPolyline" (vla-get-objectname o))
      (while p (setq r (cons (mapcar '+ p '(0 0)) r)) (setq p (cddr p)))
      (while p (setq r (cons (mapcar '+ p '(0 0 0)) r)) (setq p (cdddr p)))
    )
    (reverse r)
  )
  (if (setq s (ssget '((0 . "*POLYLINE"))))
    (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
      (setq z (_foo (vlax-ename->vla-object e)))
      (setq pts (cons (mapcar '(lambda (r j) (list r j)) z (cdr z)) pts))
    )
  )
  (while (cadr pts)
    (setq a (car pts))
    (setq pts (cdr pts))
    (foreach p a
      (foreach p2 (apply 'append pts)
	(and (inters (_f (car p)) (_f (cadr p)) (_f (car p2)) (_f (cadr p2)))
	     (progn (grdraw (car p) (cadr p) 1) (grdraw (car p2) (cadr p2) 1))
	)
      )
    )
  )
  (princ)
)

Edited December 19, 2022 by ronjonp

[Steven P]

thanks ronjon, I like that it highlights both crossing segments, what I have above (from MHUPP) -should- do what I want, but going to try to break this today (depending on work), so might steal parts of what you suggest

[ronjonp]

5 hours ago, Steven P said:

thanks ronjon, I like that it highlights both crossing segments, what I have above (from MHUPP) -should- do what I want, but going to try to break this today (depending on work), so might steal parts of what you suggest

If you only want to see one intersection change this:
 

(progn (grdraw (car p) (cadr p) 1) (grdraw (car p2) (cadr p2) 1))

to this

(grdraw (car p) (cadr p) 1)

Edited December 19, 2022 by ronjonp

[Steven P]

Nice, thanks.

 

 

 

Got what I want working for now, though the full LIS doesn't do curves or arcs, this part does - which is something for the future.

 

it is for a 'long section' of a buried service and overall to get the crossing services and surface profile heights where they cross. The lines representing the surface profile should a be lines, those representing other buried services could be lines or polylines, arcs I'll deal with when I find them for now - probably with something like this later.

 

For now the engineers want real work doing tomorrow, 

 

[BIGAL]

If your doing pipe design "CIVIL SITE DESIGN" takes into account crossing obstructions and shows them on a design long section while you set levels, yes obstructions have a thickness like 150mm and are based on 3d lines.

 

[Steven P]

I'll look for that Big Al, thanks, what I m making up has a couple more days work to do exactly what I want....but if that does the same it might be better

[BIGAL]

I will try to find one of their videos about using drainage design and obstructions. 

[Steven P]

I had a look at a couple just then, it looks good, now need to jump through a lot if IT hurdles to install the trial version (non company standard software, sometimes it feels like I need direct permission from the CEO, Bill Gates, and possible a god to try something)

[BIGAL]

I have a good relation ship with the owner of CSD known him for like 35+ years so if get stuck send me a PM. 

[Steven P]

will do, thanks