### Author Topic: line from a point perpendicular to a line  (Read 23093 times)

0 Members and 1 Guest are viewing this topic.

#### alanjt ##### Re: line from a point perpendicular to a line
« Reply #60 on: May 28, 2010, 01:02:46 PM »
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))`
« Last Edit: May 28, 2010, 01:30:26 PM by alanjt »
Civil 3D 2019 ~ Windohz 7 64bit
Dropbox

#### Hugo

• Bull Frog
• Posts: 332 ##### Re: line from a point perpendicular to a line
« Reply #61 on: May 28, 2010, 03:02:15 PM »
Thanks to all of you since the best

Danke an alle, ihr seit die Besten   #### chlh_jd

• Guest ##### Re: line from a point perpendicular to a line
« Reply #62 on: March 09, 2011, 02:56:18 AM »
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
« Last Edit: March 09, 2011, 03:48:29 AM by chlh_jd »