Topic: line from a point perpendicular to a line

[alanjt]

Well I think Hugo has a nice selection to choose from now 

I hope I didn't step on your toes, Ron. I was just joining in on the fun.

Not at all  ... I actually enjoy seeing how other people solve problems

Good deal. I just didn't want to offend.



Just for additional fun, here's one that will fix the line to always display text linetypes readable.

Code: [Select]

(defun c:PTL (/ ent dist pt dxf)
  ;; Alan J. Thompson, 05.28.10
  (while (and (setq ent (car (entsel "\nSelect curve: ")))
              (eq "LINE" (cdr (assoc 0 (entget ent))))
              (setq dist (cond ((getdist "\nSpecify distance <None>: "))
                               (0.)
                         )
              )
         )
    (while (setq pt (getpoint "\nSpecify point for line: "))
      (setq pt (trans pt 1 0))
      ((lambda (pol)
         ((lambda (ang)
            (if (and (> ang (* pi 0.5)) (< ang (* pi 1.5)))
              (setq dxf '(10 11))
              (setq dxf '(11 10))
            )
          )
           (angle pol pt)
         )
         (entmake (list '(0 . "LINE")
                        (cons (cadr dxf) pol)
                        (cons (car dxf)
                              (cond ((zerop dist) pt)
                                    ((polar pol (angle pol pt) dist))
                              )
                        )
                  )
         )
         ((lambda (lst / lst)
            (if (< (apply (function distance) lst)
                   (distance pol
                             (car (setq lst
                                         (vl-sort lst
                                                  (function (lambda (a b) (> (distance a pol) (distance b pol))))
                                         )
                                  )
                             )
                   )
                )
              (entmod (mapcar (function (lambda (x)
                                          (if (equal (cdr x) (cadr lst))
                                            (cons (car x) pol)
                                            x
                                          )
                                        )
                              )
                              (entget ent)
                      )
              )
            )
          )
           (list (vlax-curve-getEndPoint ent) (vlax-curve-getStartPoint ent))
         )
       )
        (vlax-curve-getClosestPointTo ent pt T)
      )
    )
  )
  (princ)
)

[Hugo]

Thanks to all of you since the best


Danke an alle, ihr seit die Besten
 

[chlh_jd]

hi , here based on Alan.J.T codes , I add osnap method and used in block

Code: [Select]

;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
;;; Edited by GSLS(SS) 2011-03-08
(defun c:Lper (/ foo ss-errexit #Ent #Read pt p0 ang ent blk?)
  (defun foo (/ is_go lst mid mod)
    (setq pt (osnap (cadr #read)
   "_end,_mid,_cen,_nod,_int,_tan,_per,_nea"
    )
    )
    (if pt
      (progn
(setq is_go T
     lst
      '("_end" "_mid" "_cen" "_nod" "_int" "_tan" "_per" "_nea")
)
(while (and is_go lst)
 (setq mid (car lst)
lst (cdr lst)
 )
 (if (equal pt (osnap (cadr #read) mid))
   (setq mod mid
 is_go nil
   )
 )
)
(if mod
 (osMark (list pt mod (cadr #read)))
)
      )
    )
    (or pt (setq pt (cadr #Read)))
    (setq pt (trans pt 1 0))
    (setq p0 (vlax-curve-getclosestpointto #Ent pt T))
  ) ;_Add osmark
  ;;line-ang
  ;;by Lee Mac
  (defun line-ang (p0 ang / ent #read)
    (setq ent
  (entget
    (entmakex (list (cons 0 "LINE") (cons 10 p0) (cons 11 p0)))
  )
    )
    (while (= 5 (car (setq #Read (grread T 13 0))))
      (entupd
(cdr
 (assoc
   -1
   (entmod
     (list
(assoc -1 ent)
(cons
 11
 (trans
   (polar
     p0
     ang
     ((if (minusp
    ((lambda (n)
(- (caddr (trans (cadr #read) 1 n))
  (caddr (trans p0 1 n))
)
     )
      (polar '(0. 0. 0.) ang 1.)
    )
  )
-
+
      )
(distance p0 (cadr #read))
     )
   )
   1
   0
 )
)
     )
   )
 )
)
      )
    )
  )
  (defun ss-errexit (msg)
    (command)
    (command)
    (if (or (= msg "Function cancelled")
   (= msg "quit / exit abort")
)
      (princ msg)
      (princ (strcat "\n错误: " msg))
    )
    (if blk?
      (entdel #ent)
    )
    (clos)
  )
  (svos)
  (setq #Ent (ss-Nentsel "\n选择曲线: ")) ;_support block
  (setq blk? (last #Ent)
#Ent (car #Ent)
  )
  (if (and #ent
  (vl-position
    (cdr (assoc 0 (entget #Ent)))
    '("LWPOLYLINE" "ARC" "LINE" "CIRCLE" "ELLIPSE" "SPLINE")
  )
      )
    (while (and (/= 25 (car (setq #Read (grread T 1 1))))
(/= (car #Read) 11)
(/= (car #Read) 2)
  )
      (princ "\r选择点: ")
      (redraw)
      (if (vl-consp (cadr #Read))
(foo)
      )
      (if p0
(grdraw p0
(trans pt 1 0)
1
) ;_ grdraw
      ) ;_ if      
      (if (and (eq 3 (car #Read)) (foo))
(if (not (equal pt p0 1e-6))
 (entmake
   (list
     '(0 . "LINE")
     (cons 10
   p0
     )
     (cons 11 pt)
   ) ;_ list
 ) ;_ entmake
 (progn ;_ the part writen by Lee Mac
   (setq ang (+ (xyp-get-AngleAtPoint #Ent p0) _pi2))
   (line-ang p0 ang)
 )
)
      ) ;_ if
    ) ;_ while    
  ) ;_ if
  (redraw)
  (clos)
  (princ)
) ;_ defun
;;;save old sysvar
(defun svos ()
  (setq #system#    '("OSMODE"     "ORTHOMODE"    "CLAYER"
     "CECOLOR"     "PLINEWID"    "CELTYPE"
     "CMDECHO"     "ELEVATION"    "PICKSTYLE"
    )
#vlale#    (mapcar 'getvar #system#)
gsls_olderr *error*
*error*    ss-errexit
  )
  (vla-startundomark
    (vla-get-activedocument (vlax-get-acad-object))
  )
)
;;;---------------------------------------------------------------------;;;
;;;call old sysvar
(defun clos ()
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-acad-object))
  )
  (MapCar 'setvar #system# #vlale#)
  (setq *error* gsls_olderr)
)
;;; Nentsel
;;; function : to nentsel a entity In situ
;;; arg      : string to princ in command-line
;;; return   : a list ( ename point is-of-block? )
;;; Note     : if the ename is of a block , the routine copy a similar entity , so you must entdel it later
;;; by GSLS(SS)
;;;
(defun ss-Nentsel (msg / en en1 pt mat ins mat ent)
  (setq en (Nentsel msg))
  (if (= (length en) 4)
    (progn
      (setq en1 (car en)
   pt (cadr en)
   mat (caddr en)
   ins (last mat)
   mat (reverse (cdr (reverse mat)))
   mat ((append
  (mapcar '(lambda (x y)
     (append x (list y))
   )
  mat
  ins
  )
  '((0. 0. 0. 1.))
)
)
      )
      (setq ent (entget en1 '("*")))
      (setq ent (vl-remove (assoc -1 ent) ent))
      (setq en1 (entmakex ent)) ;_make a new similar entity !!!
      (if en1
(progn
 (setq obj (vlax-ename->vla-object en1))
 (vla-TransformBy obj (vlax-tmatrix mat))
 (setq en1 (vlax-vla-object->ename obj))
)
      )
      (list en1 pt T)
    )
    (append en (list nil))
  )
)
;;;by xyp1964
(defun xyp-get-AngleAtPoint (ename point / oname p1 v1 pt-ang)
  (setq oname (vlax-ename->vla-object ename))
  (setq v1     (vlax-curve-getfirstderiv
oname
(vlax-curve-getparamatpoint oname point)
      )
p1     (mapcar '+ point v1)
pt-ang (angle point p1)
  )
  (vlax-release-object oname)
  pt-ang
)
;;;osmark by Evgeniy
(defun osMark (o / s drft osGrv)
  (setq s (/ (getvar "VIEWSIZE") (cadr (getvar "SCREENSIZE")))
o (cons (trans (car o) 1 3) (cdr o))
  )
  (setq osGrv (osmode-grvecs-lst
(vla-get-AutoSnapMarkerColor
 (setq drft (vla-get-drafting
      (vla-get-preferences
(vlax-get-acad-object)
      )
    )
 )
)
(vla-get-AutoSnapMarkerSize drft)
     )
  )
  (grvecs (cdr (assoc (cadr o) osGrv))
 (list (list s 0. 0. (caar o))
(list 0. s 0. (cadar o))
(list 0. 0. s (caddar o))
(list 0. 0. 0. 1.)
 )
  )
)
about osmark you can see here
http://www.theswamp.org/index.php?topic=12813.0