line perpendicular to a point... help

January 30, 2023

hello all:

i am using this routine...

to draw a line perpendicular to an element

the problem is that I would like it to be perpendicular to a point

1.- that is, select the element

2.- select a starting point permanent

3.- select final point

;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
(defun c:LPe (/ #Ent #Read)
  (and
    (setq #Ent (car (entsel "\nSelect curve: ")))
    (vl-position (cdr (assoc 0 (entget #Ent))) '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE"))
    (while (not (eq 25 (car (setq #Read (grread T 15 0)))))
      (princ "\rSpecify point for line: ")
      (redraw)
      (if (vl-consp (cadr #Read))
        (grdraw (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T)
                (trans (cadr #Read) 1 0)
                1
        ) ;_ grdraw
      ) ;_ if
      (if (eq 3 (car #Read))
        (entmake (list '(0 . "LINE")
                       (cons 10 (vlax-curve-getclosestpointto #Ent (trans (cadr #Read) 1 0) T))
                       (cons 11 (trans (cadr #Read) 1 0))
                       
                 ) ;_ list
        ) ;_ entmake

      ) ;_ if
    ) ;_ while
  ) ;_ and

  (redraw)
  (princ)
) ;_ defun

Edited September 13 by SLW210
Added Code Tags!!

January 30, 2023

This doesn't make any sense maybe a example drawing?

January 30, 2023

this routine does what i need but it doesn't show the line while i select point two...

I think the command grdraw is required

(defun c:perp2ent (/ entity pt lyr ep sp ppt ang1 ang2 obj)
  (while (and (setq entity (car (entsel "\nSelect entity: ")))
              (setq obj (vlax-ename->vla-object entity))
         )
    (while (setq pt (getpoint "\nSelect point to draw perpendicular from: "))
      (setq sp   (vlax-curve-getstartpoint obj)
            ep   (vlax-curve-getendpoint obj)
            ppt  (vlax-curve-getclosestpointto entity (trans pt 1 0))
            ang1 (angle (vlax-curve-getpointatparam
                          obj
                          (+ (vlax-curve-getparamatpoint obj sp) 0.01)
                        )
                        sp
                 )
            ang2 (angle (vlax-curve-getpointatparam
                          obj
                          (* (vlax-curve-getparamatpoint obj ep) 0.99)
                        )
                        ep
                 )
      )
      (cond ((equal ppt sp 0.0001)
             (setq ppt (inters sp
                               (polar sp ang1 0.01)
                               pt
                               (polar pt (+ ang1 (/ pi 2.)) 0.01)
                               onseg
                       )
             )
             (if (= (vla-get-objectname obj) "AcDbLine")
               (vlax-put obj 'startpoint ppt)
             )
            )
            ((equal ppt ep 0.0001)
             (setq ppt (inters ep
                               (polar ep ang2 0.01)
                               pt
                               (polar pt (+ ang2 (/ pi 2.)) 0.01)
                               onseg
                       )
             )
             (if (= (vla-get-objectname obj) "AcDbLine")
               (vlax-put obj 'endpoint ppt)
             )
            )
      )
      (entmake (list '(0 . "LINE")
                     (cons 8 (cdr (assoc 8 (entget entity))))
                     (cons 10 (trans pt 1 0))
                     (cons 11 ppt)
               )
      )
    )
  )
  (princ)
)

Edited September 13 by SLW210
Added Code Tags!!

January 30, 2023

Why not this simple

(defun c:ptperp ( / e p1 p2 )

  (vl-load-com)

  (if
    (and
      (setq e (car (nentsel "\nPick entity to draw perpendicular line to...")))
      (setq p1 (trans (getpoint "\nPick or specify point to draw perpendicular line from : ") 1 0))
      (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-curve-getstartpoint) (list e))))
    )
    (progn
      (setq p2 (vlax-curve-getclosestpointto e p1 t))
      (entmake
        (list
          (cons 0 "LINE")
          (cons 10 p1)
          (cons 11 p2)
          (cons 62 3)
        )
      )
    )
  )
  (princ)
)

Edited January 30, 2023 by marko_ribar

January 30, 2023

Use (1) when posting code.

January 30, 2023

If you want it to show a line then perhaps you could draw a line, and entmod point 1 to make it perpendicular? this will show you the 'line'

Else you could look to Lee Mac and his GrSnap examples

Edited January 30, 2023 by Steven P

January 30, 2023

I liked this routine ,

but I need that, in addition to selecting an element, it asks me for a point in that element

For example, if I want to make the line perpendicular to the end of that line

(defun C:test ( / e grr Stop )
 (if (setq e (car (entsel "\nSelect line, or curve: ")))
   (while (not Stop)
     (setq grr (grread T))
     (cond
       ( (= (car grr) 25) (setq Stop T) )
       ( (= (car grr) 5) (redraw) (grdraw (cadr grr) (vlax-curve-getClosestPointTo e (cadr grr) T) 2) )
       ( (= (car grr) 3) 
         (entmakex 
           (list (cons 0 "LINE") (cons 10 (cadr grr)) (cons 11 (vlax-curve-getClosestPointTo e (cadr grr) T)) )
         )
         (setq Stop T)
       )
     ); cond			
   ); while
 ); if
 (princ)
); defun

TEST.dwg

January 30, 2023

Maybe this have another that does not use VL.

; offset perpendicular to end of line
; by alan H 2018

(defun c:sqp ( / pt1 pt2 pt3 pt4)
(setq tp1 (entsel "\nSelect line near end : "))
(setq tpp1 (entget (car tp1)))
(setq pt1 (cdr (assoc 10 tpp1)))
(setq pt1 (list (car pt1) (cadr pt1) 0.0)) ;reset z to zero
(setq pt2 (cdr (assoc 11 tpp1)))      
(setq pt2 (list (car pt2) (cadr pt2) 0.0)) ;reset z to zero
(setq pt3 (cadr tp1))
(setq d1 (distance pt1 pt3))
(setq d2 (distance pt2 pt3))
(if (> d1 d2)
(progn 
	(setq temp pt1)
	(setq pt1 pt2)
	(setq pt2 temp)
)
)
(setq ang (angle pt1 pt2))
(setq pt3 (getpoint "\nSelect point"))
(command "line" pt1 pt2 "")
(setq obj (vlax-ename->vla-object (car tp1)))
(setq pt4 (vlax-curve-getclosestpointto obj pt3))
(setq len (distance pt3 pt4))
(setq ang (angle pt4 pt3))
(setq pt3 (polar pt1 ang len))
(command "line" pt1 pt3 "")
(Princ) 
)
(C:sqp)

Edited January 30, 2023 by BIGAL

January 31, 2023

This?

(defun elperr (ch)
  (cond
    ((eq ch "Function cancelled") nil)
    ((eq ch "quit / exit abort") nil)
    ((eq ch "console break") nil)
    (T (princ ch))
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" old_osmd)
  (setvar "orthomode" old_orth)
  (setvar "snapang" old_snp)
  (setq *error* olderr)
  (princ)
)
(defun c:elp ( / olderr js ent-sel ent pt_sel obj_curv old_osmd old_snp old_orth param deriv pt_tmp p_from p_to)
  (vl-load-com)
  (setq olderr *error* *error* elperr)
  (princ "\nRaise a perpendicular to: ")
  (while (not (setq js (ssget "_+.:E:S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE,RAY"))))))
  (setq
    ent-sel (ssnamex js 0)
    ent (cadar ent-sel)
    pt_sel (cadar (cdddar ent-sel))
    obj_curv (vlax-ename->vla-object ent)
  )
  (cond
    ((member
      (vlax-get-property obj_curv 'ObjectName)
      '("AcDbPolyline" "AcDb2dPolyline" "AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbSpline" "AcDbRay" "AcDbXline")
     )
      (setq
        old_osmd (getvar "osmode")
        old_snp (getvar "snapang")
        old_orth (getvar "orthomode")
        pt_sel (vlax-curve-getClosestPointTo obj_curv pt_sel)
        param (vlax-curve-getparamatpoint obj_curv pt_sel)
        deriv (vlax-curve-getfirstderiv obj_curv param)
      )
      (setq pt_tmp (polar pt_sel (+ (atan (cadr deriv) (car deriv)) (/ pi 2)) 100.0))
      (setvar "snapang" (angle (trans pt_sel 0 1) (trans pt_tmp 0 1)))
      (setvar "orthomode" 1)
      (if (null (setq p_from (getpoint "\nFrom point <lastpoint>: ")))
        (setq p_from (trans pt_sel 0 1))
      )
      (setvar "osmode" 0)
      (initget 9)
      (setq p_to (getpoint p_from "\nTo point : "))
      (command "_.line" p_from p_to "")
      (setvar "osmode" old_osmd)
      (setvar "orthomode" old_orth)
      (setvar "snapang" old_snp)
    )
    (T (princ "\nInvalid object!"))
  )
  (setq *error* olderr)
  (princ)
)

Edited January 31, 2023 by Tsuky

January 31, 2023

DEAR TSUKY :

it is exactly what i needed

but...

You could add something so that when the command is interrupted, the variables such as the cursor position and the osnap they return to their initial position.

thanks

January 31, 2023

leonucadomi

I edited the previous post to insert an *error* function, this resolves if the command is interrupted.

February 1, 2023

excellent thanks

February 1, 2023

FYI when you need to set multiple variables

(setq vars '(osmode snapang orthomode cmdecho)  ;list of variables
      vals (mapcar 'getvar vars)        ;store current values for restore in a list called 'vals
)
(mapcar 'setvar vars '(0 0 1 0))        ;set new values setting osmode=0 snapang=0 orthomode=1 cmdecho=0
                                        ;use this before you acually set the snapang so 0 is overwritten
(mapcar 'setvar vars vals)              ;restore old values

February 1, 2023

On 1/30/2023 at 5:14 PM, Tsuky said:

This?

(defun elperr (ch)
  (cond
    ((eq ch "Function cancelled") nil)
    ((eq ch "quit / exit abort") nil)
    ((eq ch "console break") nil)
    (T (princ ch))
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" old_osmd)
  (setvar "orthomode" old_orth)
  (setvar "snapang" old_snp)
  (setq *error* olderr)
  (princ)
)
(defun c:elp ( / olderr js ent-sel ent pt_sel obj_curv old_osmd old_snp old_orth param deriv pt_tmp p_from p_to)
  (vl-load-com)
  (setq olderr *error* *error* elperr)
  (princ "\nRaise a perpendicular to: ")
  (while (not (setq js (ssget "_+.:E:S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE,RAY"))))))
  (setq
    ent-sel (ssnamex js 0)
    ent (cadar ent-sel)
    pt_sel (cadar (cdddar ent-sel))
    obj_curv (vlax-ename->vla-object ent)
  )
  (cond
    ((member
      (vlax-get-property obj_curv 'ObjectName)
      '("AcDbPolyline" "AcDb2dPolyline" "AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbSpline" "AcDbRay" "AcDbXline")
     )
      (setq
        old_osmd (getvar "osmode")
        old_snp (getvar "snapang")
        old_orth (getvar "orthomode")
        pt_sel (vlax-curve-getClosestPointTo obj_curv pt_sel)
        param (vlax-curve-getparamatpoint obj_curv pt_sel)
        deriv (vlax-curve-getfirstderiv obj_curv param)
      )
      (setq pt_tmp (polar pt_sel (+ (atan (cadr deriv) (car deriv)) (/ pi 2)) 100.0))
      (setvar "snapang" (angle (trans pt_sel 0 1) (trans pt_tmp 0 1)))
      (setvar "orthomode" 1)
      (if (null (setq p_from (getpoint "\nFrom point <lastpoint>: ")))
        (setq p_from (trans pt_sel 0 1))
      )
      (setvar "osmode" 0)
      (initget 9)
      (setq p_to (getpoint p_from "\nTo point : "))
      (command "_.line" p_from p_to "")
      (setvar "osmode" old_osmd)
      (setvar "orthomode" old_orth)
      (setvar "snapang" old_snp)
    )
    (T (princ "\nInvalid object!"))
  )
  (setq *error* olderr)
  (princ)
)

FWIW .. using the built in *error* function is a bit simpler like so ( also don't forget to localize it (defun c:elp (/ *error* ... )

(defun c:elp (/	*error*	deriv ent ent-sel js obj_curv old_orth old_osmd	old_snp	param pt_sel pt_tmp
	      p_from p_to)
  (defun *error* (msg)
    (and old_osmd (setvar "osmode" old_osmd))
    (and old_orth (setvar "orthomode" old_orth))
    (and old_snp (setvar "snapang" old_snp))
    (if	(not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (princ "\nRaise a perpendicular to: ")
  (while (not (setq js (ssget "_+.:E:S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE,RAY"))))))
  (setq	ent-sel	 (ssnamex js 0)
	ent	 (cadar ent-sel)
	pt_sel	 (cadar (cdddar ent-sel))
	obj_curv (vlax-ename->vla-object ent)
  )
  (cond	((member (vlax-get-property obj_curv 'objectname)
		 '("AcDbPolyline"    "AcDb2dPolyline"  "AcDbLine"	 "AcDbArc"
		   "AcDbCircle"	     "AcDbEllipse"     "AcDbSpline"	 "AcDbRay"
		   "AcDbXline"
		  )
	 )
	 (setq old_osmd	(getvar "osmode")
	       old_snp	(getvar "snapang")
	       old_orth	(getvar "orthomode")
	       pt_sel	(vlax-curve-getclosestpointto obj_curv pt_sel)
	       param	(vlax-curve-getparamatpoint obj_curv pt_sel)
	       deriv	(vlax-curve-getfirstderiv obj_curv param)
	 )
	 (setq pt_tmp (polar pt_sel (+ (atan (cadr deriv) (car deriv)) (/ pi 2)) 100.0))
	 (setvar "snapang" (angle (trans pt_sel 0 1) (trans pt_tmp 0 1)))
	 (setvar "orthomode" 1)
	 (if (null (setq p_from (getpoint "\nFrom point <lastpoint>: ")))
	   (setq p_from (trans pt_sel 0 1))
	 )
	 (setvar "osmode" 0)
	 (initget 9)
	 (setq p_to (getpoint p_from "\nTo point : "))
	 (command "_.line" p_from p_to "")
	 (setvar "osmode" old_osmd)
	 (setvar "orthomode" old_orth)
	 (setvar "snapang" old_snp)
	)
	(t (princ "\nInvalid object!"))
  )
  (princ)
)
(vl-load-com)

September 13

On 1/31/2023 at 12:14 AM, Tsuky said:

This?

(defun elperr (ch)
  (cond
    ((eq ch "Function cancelled") nil)
    ((eq ch "quit / exit abort") nil)
    ((eq ch "console break") nil)
    (T (princ ch))
  )
  (setvar "cmdecho" 1)
  (setvar "osmode" old_osmd)
  (setvar "orthomode" old_orth)
  (setvar "snapang" old_snp)
  (setq *error* olderr)
  (princ)
)
(defun c:elp ( / olderr js ent-sel ent pt_sel obj_curv old_osmd old_snp old_orth param deriv pt_tmp p_from p_to)
  (vl-load-com)
  (setq olderr *error* *error* elperr)
  (princ "\nRaise a perpendicular to: ")
  (while (not (setq js (ssget "_+.:E:S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE,RAY"))))))
  (setq
    ent-sel (ssnamex js 0)
    ent (cadar ent-sel)
    pt_sel (cadar (cdddar ent-sel))
    obj_curv (vlax-ename->vla-object ent)
  )
  (cond
    ((member
      (vlax-get-property obj_curv 'ObjectName)
      '("AcDbPolyline" "AcDb2dPolyline" "AcDbLine" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbSpline" "AcDbRay" "AcDbXline")
     )
      (setq
        old_osmd (getvar "osmode")
        old_snp (getvar "snapang")
        old_orth (getvar "orthomode")
        pt_sel (vlax-curve-getClosestPointTo obj_curv pt_sel)
        param (vlax-curve-getparamatpoint obj_curv pt_sel)
        deriv (vlax-curve-getfirstderiv obj_curv param)
      )
      (setq pt_tmp (polar pt_sel (+ (atan (cadr deriv) (car deriv)) (/ pi 2)) 100.0))
      (setvar "snapang" (angle (trans pt_sel 0 1) (trans pt_tmp 0 1)))
      (setvar "orthomode" 1)
      (if (null (setq p_from (getpoint "\nFrom point <lastpoint>: ")))
        (setq p_from (trans pt_sel 0 1))
      )
      (setvar "osmode" 0)
      (initget 9)
      (setq p_to (getpoint p_from "\nTo point : "))
      (command "_.line" p_from p_to "")
      (setvar "osmode" old_osmd)
      (setvar "orthomode" old_orth)
      (setvar "snapang" old_snp)
    )
    (T (princ "\nInvalid object!"))
  )
  (setq *error* olderr)
  (princ)
)

I'm having a bit trouble getting this useful lips working in bricscad.

Initially it would error in this bit:

pt_sel (cadar (cdddar ent-sel))

changing it to this seems to work (i think)

pt_sel (cdr (cdr (cdr (car ent-sel))))

Bur now it fails on this bit:

Command: LPER

Raise a perpendicular to:
Select entities:
; ----- LISP : Call Stack -----
; [0]...C:LPER <<--
;
; ----- Error around expression -----
; (VLAX-CURVE-GETCLOSESTPOINTTO OBJ_CURV PT_SEL)
; in file :
; D:\360G\Support\Lsp\LPER.lsp
;bad argument type <(-1)> ; expected <LIST> at [vlax-curve-getclosestpointto]

any ideas why?

Thanks

P

LPER.lsp

September 13

Change it to this :

(setq
  ent-sel (ssnamex js)
  ent (cadar ent-sel)
  pt_sel (osnap (getvar (quote lastpoint)) "_nea")
  obj_curv (vlax-ename->vla-object ent)
)

September 13

Ah yes! Thats perfect. Thanks marko!

line perpendicular to a point... help

Recommended Posts

leonucadomi

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

leonucadomi

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

Steven P

Link to comment

Share on other sites

leonucadomi

Link to comment

Share on other sites

BIGAL

Link to comment

Share on other sites

Tsuky

Link to comment

Share on other sites

leonucadomi

Link to comment

Share on other sites

Tsuky

Link to comment

Share on other sites

leonucadomi

Link to comment

Share on other sites

mhupp

Link to comment

Share on other sites

ronjonp

Link to comment

Share on other sites

Least

Link to comment

Share on other sites

marko_ribar

Link to comment

Share on other sites

Least

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity