Perpendicular Lines from many points to a Polyline

[rifad_cad]

Hi, I'm a newbie to autocad LISP and also to the forum. I have to create perpendicular lines to a polyline from points adjoining to it. I can manually do that one by one but I have several thousand points either side of the very long polyline and it is difficult to do that one by one. Is there anyway i can quickly draw perpendicular lines from the points to the polyline. the drawing is 2D and below is a small sample to of the drawing just to illustrate.

 

[Emmanuel Delay]

My code used to do a similar thing (you can find it in the list of my replies on this forum): move blocks perperdicular to multiple polylines, first find the closest polyline to the block.

 

I changed it to select points, and to draw lines instead of moving the blocks.  I think it does what you require,

but it has remnants of the old code, so it has lines of code that are not needed anymore.

 

So if you select multiple polylines it will draw a line to the closest one.

 

- Command STO (feel free to change this)

- select polyline(s)

-select points

 

(defun Line (p1 p2)
 (entmakex (list (cons 0 "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
                 )))

;;; Modified code from: http://www.arch-pub.com/Move-point-perpendicular-to-line_10272335.html
;;; By: Mel Franks

(defun c:sto ( / en obj pts_ss ss_len c pten ptobj pted pt pt2 this_is_the_point best_distance)
  (princ "\nSelect polyline: ")
  (setq en (ssget (list
      (cons 0 "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE")
    ))
  )
  (princ "\nSelect Points: ")
  (setq pts_ss (ssget (list (cons 0 "POINT"))))  
  (setq ss_len (sslength pts_ss))
  (setq c 0)
  (while (< c ss_len)
    (setq pten (ssname pts_ss c))
    (setq ptobj (vlax-ename->vla-object pten))
    (setq pted (entget pten))
    (setq pt (cdr (assoc 10 pted)))

    (setq cnt 0)
    (setq best_distance 1000000)  ;; and we will search for something better.  As long as it keeps dropping we are happy
    (setq this_is_the_point nil)
    (while (< cnt (sslength en))
      (setq ename (ssname en cnt))
      (setq pt2 (vlax-curve-getClosestPointTo ename pt))
      (if (< (distance pt pt2) best_distance) (progn
        (setq best_distance (distance pt pt2))
        (setq this_is_the_point pt2)
      ))
      (setq cnt (+ cnt 1))
    )
    ;;(vla-move ptobj (vlax-3d-point pt) (vlax-3d-point this_is_the_point))
    (Line pt this_is_the_point)
    ;;(vla-Rotate ptobj (vlax-3d-point this_is_the_point) (angle pt this_is_the_point))
    ;;(vla-Rotate ptobj this_is_the_point 1 )
    (setq c (+ c 1))
  )
(princ)
)

[rifad_cad]

Dear Emmanuel Delay, Thank you very much. The code work very well and it does what I want. 

Just one thing to ask, the text display on the command line always says "Select Object" in both instances (i.e. ask to select 'polyline' and 'points'). see below images. Is it possible to change to 'Select polyline' and 'Select Point'?

Thanks again. 

 

[Emmanuel Delay]

Yes, for example like this:

 

...

  (setvar "nomutt" 1)  ;; shut up ssget
  (setq en (ssget (list
      (cons 0 "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE")
    ))
  )
  (princ "\nSelect Points: ")
 
  (setq pts_ss (ssget (list (cons 0 "POINT"))))  
  (setq ss_len (sslength pts_ss))
  (setvar "nomutt" 0)  ;; set the variable back

...

[Lee Mac]

Here's another -

(defun c:ppl ( / ent idx pnt sel )
    (if
        (and (setq sel (LM:ssget "\nSelect points: " '(((0 . "POINT")))))
            (progn
                (while
                    (progn (setvar 'errno 0) (setq ent (entsel "\nSelect curve: "))
                        (cond
                            (   (= 7 (getvar 'errno))
                                (princ "\nMissed, try again.")
                            )
                            (   (null ent) nil)
                            (   (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getclosestpointto ent))
                                (princ "\nInvalid object selected.")
                            )
                        )
                    )
                )
                (setq ent (car ent))
            )
        )
        (repeat (setq idx (sslength sel))
            (setq idx (1- idx)
                  pnt (assoc 10 (entget (ssname sel idx)))
            )
            (entmake (list '(0 . "LINE") pnt (cons 11 (vlax-curve-getclosestpointto ent (cdr pnt)))))
        )
    )
    (princ)
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget arg))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)
(vl-load-com) (princ)

 

Edited January 10, 2019 by Lee Mac

[ronjonp]

Another one for fun

(defun c:foo (/ _dxf _sl a b c e p s x)
  ;; RJP » 2019-01-10
  (defun _sl (s) (cond ((= 'pickset (type s)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))))
  (defun _dxf (c e) (cdr (assoc c (entget e))))
  (cond
    ((setq s (_sl (ssget)))
     (foreach x	s
       (if (wcmatch (_dxf 0 x) "CIRCLE,INSERT,POINT")
	 (setq b (cons (_dxf 10 x) b))
	 (and (= 'real (type (vl-catch-all-apply 'vlax-curve-getendparam (list x))))
	      (setq a (cons x a))
	 )
       )
     )
     (and a
	  b
	  (foreach p b
	    (setq c
		   (mapcar '(lambda (x)
			      (list (setq c (vlax-curve-getclosestpointto x p)) (distance p c) (_dxf 8 x))
			    )
			   a
		   )
	    )
	    (setq c (car (vl-sort c '(lambda (r j) (< (cadr r) (cadr j))))))
	    (if	(not (equal 0 (cadr c) 1e-3))
	      (progn (setq
		       e (entmakex (list '(0 . "line") (cons 10 p) (cons 11 (car c)) (cons 8 (caddr c))))
		     )
		     ;; This line below creates the right example comment out to get left
		     (setq a (cons e a))
	      )
	    )
	  )
     )
    )
  )
  (princ)
)

 

Edited August 3, 2021 by ronjonp
*speed improvement

[rifad_cad]

Thank you all..

[minejash]

is it possible to change this lisp to get Perpendicular line from a Point to Perpendicular line from a BLOCK BASE POINT ?

i mean first select the polyline and then select all blocks and it'll create a perpendicular line to the polyline/line/arc ive selected and draw a line. The lisp above creates the same but i can only select points, not blocks. Leemacs and Emmanuels lisp are working great with points(foo lisp had some errors)

 

i don't know much about lisp codes and all, please help if possible.. Thanks..

[Emmanuel Delay]

Sure, just change line 17 in my code to ( change "POINT" to "INSERT")

 

(setq pts_ss (ssget (list (cons 0 "INSERT"))))

 

Then you can change the messages if you feel like it.

(princ "\nSelect polyline: ")  ;; it also works for line, spline, ...

(princ "\nSelect Points: ")    ;; it's not points anymore

[ronjonp]

9 hours ago, minejash said:

..(foo lisp had some errors)

 

...

Can you elaborate? Is it the fact that only LWPOLYLINES are used?

 

Just guessing but this should do what you want:

(defun c:foo (/ _dxf _sl a b c e p s x)
  ;; RJP » 2019-01-10
  (defun _sl (s) (cond ((= 'pickset (type s)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex s))))))
  (defun _dxf (c e) (cdr (assoc c (entget e))))
  (cond
    ((setq s (_sl (ssget)))
     (foreach x	s
       (if (wcmatch (_dxf 0 x) "CIRCLE,INSERT,POINT")
	 (setq b (cons (_dxf 10 x) b))
	 (and (= 'real (type (vl-catch-all-apply 'vlax-curve-getendparam (list x))))
	      (setq a (cons x a))
	 )
       )
     )
     (and a
	  b
	  (foreach p b
	    (setq c
		   (car	(vl-sort
			  (mapcar
			    '(lambda (x)
			       (list (setq c (vlax-curve-getclosestpointto x p)) (distance p c) (_dxf 8 x))
			     )
			    a
			  )
			  '(lambda (r j) (< (cadr r) (cadr j)))
			)
		   )
	    )
	    (setq e (entmakex (list '(0 . "line") (cons 10 p) (cons 11 (car c)) (cons 8 (caddr c)))))
	    ;; This line below creates the right example comment out to get left
	    ;; (setq a (cons e a))
	  )
     )
    )
  )
  (princ)
)

 

Edited July 24, 2019 by ronjonp

[minejash]

@Emmanuel Delay @ronjonp Thank you so much Both of you, Both are working perfect and as i wanted. 

 

@ronjonpThe foo lisp was working before also but it just adds a line to the nearest block insert (not to the line perpendicular),have attached a snap. Thanks now the code is working as i wanted.

[Nicci]

Can any of the routines provided here be modified to move a lot of points to a selected polyline at the location where they would intersect perpendicularly.

[rkmcswain]

27 minutes ago, Nicci said:

Can any of the routines provided here be modified to move a lot of points to a selected polyline at the location where they would intersect perpendicularly.

 

@Nicci - since this thread is kind of old, you might want to tag some of the posters in here to grab their attention.

 

@BlackBox

 

@Emmanuel Delay

 

@ronjonp

[dlanorh]

1 hour ago, Nicci said:

Can any of the routines provided here be modified to move a lot of points to a selected polyline at the location where they would intersect perpendicularly.

 

 Try this

 

(defun c:mper ( / ent ss cnt e_lst i_pt c_pt)
  (setq ent (car (entsel "\nSelect Line Entity : ")))
  (cond ( (vl-position (cdr (assoc 0 (entget ent))) '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE" "SPLINE"))
          (prompt "\nSelect Points : ")
          (setq ss (ssget '((0 . "POINT"))))
          (repeat (setq cnt (sslength ss))
            (setq i_pt (cdr (assoc 10 (setq e_lst (entget (ssname ss (setq cnt (1- cnt)))))))
                  c_pt (vlax-curve-getclosestpointto ent i_pt)
            )
            (entmod (subst (cons 10 c_pt) (assoc 10 e_lst) e_lst))
          );end_repeat
        )
        ( (alert "Not a Line Entity"))
  );end_cond
  (princ)
);end_defun

 

[ronjonp]

@dlanorh You might as well include an if statement for the entsel otherwise entget will STB. 

[Nicci]

@dlanorh Thank you for your response.  I tried your routine and it wont allow me to select my polyline.  I am not very familiar with the language. perhaps this is what @ronjonp is referring to in his comment.

Also, after thinking about it, I would also like to have the option to move points OR text.  

[ronjonp]

If you want to move points or text simply change the filter:

(setq ss (ssget '((0 . "POINT,TEXT"))))

I tested @dlanorh code above and it works fine?

[Nicci]

@dlanorh @ronjonp Thank you both so much!  The problem was that my polyline was a 2D polyline, so once i converted it the routine worked like a charm. This will save me a lot of time.

[asra]

@dlanorh thaks for share this Lisp, It's very cool 

but can the value of Z be fixed, not 0?

[Lee Mac]

Hint: use the vlax-curve-getclosestpointtoprojection function instead, for reasons I describe here.

Edited October 17, 2019 by Lee Mac