A change lisp... Draw perpendicular line lisp

[hosneyalaa]

Sorry English is not good

Hello all the members

 

 please help

Find a code Dynamic drawing a line to  poyline  perpendicular  

on this link

http://www.theswamp.org/index.php?topic=12813.30

Is it possible to change the lisp ?

When we choose a point
The lisp ends working
After drawing one orthogonal line

It gives the length of the line
And
Coordinates of the selection point

And

Location the selection point left or right of polyline

 

Thanks!

this lisp 

 

;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
(defun c:LPer (/ #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

[ronjonp]

Not exactly sure what you're asking but give this a try:

;;; Draw perpendicular line
;;; Alan J. Thompson, 10.15.09
(defun c:lper (/ #ent #read p1 p2)
  (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
      (cond
	((eq 3 (car #read))
	 (entmake
	   (list '(0 . "LINE")
		 (cons 10 (setq p1 (vlax-curve-getclosestpointto #ent (trans (cadr #read) 1 0) t)))
		 (cons 11 (setq p2 (trans (cadr #read) 1 0)))
	   ) ;_ list
	 ) ;_ entmake
	 ;; Print results of distance, closest point to object and picked point
	 (print (distance p1 p2))
	 (print p1)
	 (print p2)
	)
      ) ;_ if
    ) ;_ while
  ) ;_ and
  (redraw)
  (princ)
) ;_ defun

 

[hosneyalaa]

ronjonp Thanks!

I want to stop working  function while

I do not want to continue function while

Give the result only one time

if possible

 

[Lee Mac]

Try the following:

(defun c:lpr ( / e g p q )
    (while
        (not 
            (progn (setvar 'errno 0) (setq e (entsel))
                (cond
                    (   (= 7 (getvar 'errno))
                        (prompt "\nMissed, try again.")
                    )
                    (   (null e))
                    (   (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getclosestpointto e))
                        (prompt "\nInvalid object selected.")
                    )
                    (   (setq e (car e))
                        (while (= 5 (car (setq g (grread t 13 0))))
                            (redraw)
                            (if (setq q (vlax-curve-getclosestpointto e (trans (cadr g) 1 0) t))
                                (grdraw (cadr g) (trans q 0 1) 1)
                            )
                        )
                        (if (= 3 (car g))
                            (progn
                                (entmake
                                    (list
                                       '(0 . "LINE")
                                        (cons 10 (setq p (trans (cadr g) 1 0)))
                                        (cons 11 (setq q (vlax-curve-getclosestpointto e (trans (cadr g) 1 0) t)))
                                    )
                                )
                                (princ "\nLine endpoints: ") (princ p) (princ " | ") (princ q)
                                (princ "\nLength: ") (princ (distance p q))
                            )
                            t
                        )
                    )
                )
            )
        )
    )
    (redraw) (princ)
)

 

[ssdd]

(defun c:lpr ( / e g p q )
  (LM:grsnap:snapfunction)
    (while
        (not 
            (progn (setvar 'errno 0) (setq e (entsel))
                (cond
                    (   (= 7 (getvar 'errno))
                        (prompt "\nMissed, try again.")
                    )
                    (   (null e))
                    (   (vl-catch-all-error-p (vl-catch-all-apply 'vlax-curve-getclosestpointto e))
                        (prompt "\nInvalid object selected.")
                    )
                    (
             (setq osf (LM:grsnap:snapfunction)osm (getvar 'osmode))

             (setq e (car e))
                        (while (= 5 (car (setq g (grread t 13 0))))
                            (redraw)(osf (cadr g) osm)
                            (if (setq q (vlax-curve-getclosestpointto e (trans (cadr g) 1 0) t))
                                (grdraw (cadr g) (trans q 0 1) 1)
                            )
                        )
                        (if (= 3 (car g))
                            (progn
                                (entmake
                                    (list
                                       '(0 . "LINE")
                                        (cons 10 (setq p (trans (cadr g) 1 0)))
                                        (cons 11 (setq q (vlax-curve-getclosestpointto e (trans (cadr g) 1 0) t)))
                        (cons 62 2)
                                    )
                                )
                  (entmakex (list (cons 0 "TEXT")
                                (cons 10 (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p q)))
                    (cons 11 (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p q)))
                                (cons 1 (rtos (distance p q) 2 2))
                    (cons 50 (LM:readable(angle p q)))
                                (cons 62 1)(cons 40 30)(cons 41 0.7)(cons 72 1)(cons 73 1)
                    ))
                                (princ "\nLine endpoints: ") (princ p) (princ " | ") (princ q)
                                (princ "\nLength: ") (princ (distance p q))
                            )
                            t
                        )
                    )
                )
            )
        )
    )
    (redraw) (princ)
)

(defun LM:readable ( a )
    (   (lambda ( a )
            (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
                (LM:readable (+ a pi))
                a
            )
        )
        (rem (+ a pi pi) (+ pi pi))
    )
)


;; Object Snap for grread: Snap Function - Lee Mac
;; Returns: [fun] A function requiring two arguments:
;; p - [lst] UCS Point to be snapped
;; o - [int] Object Snap bit code
;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
;; or the supplied point if the snap failed for the given Object Snap bit code.
(defun LM:grsnap:snapfunction ( )
(eval
(list 'lambda '( p o / q )
(list 'if '(zerop (logand 16384 o))
(list 'if
'(setq q
(cdar
(vl-sort
(vl-remove-if 'null
(mapcar
(function
(lambda ( a / b )
(if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
(list (distance p b) b (car a))
)
)
)
'(
(0001 . "_end")
(0002 . "_mid")
(0004 . "_cen")
(0008 . "_nod")
(0016 . "_qua")
(0032 . "_int")
(0064 . "_ins")
(0128 . "_per")
(0256 . "_tan")
(0512 . "_nea")
(2048 . "_app")
(8192 . "_par")
)
)
)
'(lambda ( a b ) (< (car a) (car b)))
)
)
)
(list 'LM:grsnap:displaysnap '(car q)
(list 'cdr
(list 'assoc '(cadr q)
(list 'quote
(LM:grsnap:snapsymbols
(atoi (cond ((getenv "AutoSnapSize")) ("5")))
)
)
)
)
(LM:OLE->ACI
(if (= 1 (getvar 'cvport))
(atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
(atoi (cond ((getenv "Model AutoSnap Color")) ("104193")))
)
)
)
)
)
'(cond ((car q)) (p))
)
)
)
;; Object Snap for grread: Display Snap - Lee Mac
;; pnt - [lst] UCS point at which to display the symbol
;; lst - [lst] grvecs vector list
;; col - [int] ACI colour for displayed symbol
;; Returns nil
(defun LM:grsnap:displaysnap ( pnt lst col / scl )
(setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
pnt (trans pnt 1 2)
)
(grvecs (cons col lst)
(list
(list scl 0.0 0.0 (car pnt))
(list 0.0 scl 0.0 (cadr pnt))
(list 0.0 0.0 scl 0.0)
'(0.0 0.0 0.0 1.0)
)
)
)
;; Object Snap for grread: Snap Symbols - Lee Mac
;; p - [int] Size of snap symbol in pixels
;; Returns: [lst] List of vector lists describing each Object Snap symbol
(defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
(setq -p (- p) q (1+ p)
-q (- q) r (+ 2 p)
-r (- r) i (/ pi 6.0)
a 0.0
)
(repeat 12
(setq l (cons (list (* r (cos a)) (* r (sin a))) l)
a (- a i)
)
)
(setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
(list
(list 1
(list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
)
(list 2
(list -r -q) (list 0 r) (list 0 r) (list r -q)
(list -p -p) (list p -p) (list p -p) (list 0 p) (list 0 p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list 0 q) (list 0 q) (list -q -q)
)
(cons 4 c)
(vl-list* 8 (list -r -r) (list r r) (list r -r) (list -r r) c)
(list 16
(list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
(list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
(list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
)
(list 32
(list r r) (list -r -r) (list r q) (list -q -r) (list q r) (list -r -q)
(list -r r) (list r -r) (list -q r) (list r -q) (list -r q) (list q -r)
)
(list 64
'( 0 1) (list 0 p) (list 0 p) (list -p p) (list -p p) (list -p -1) (list -p -1) '( 0 -1)
'( 0 -1) (list 0 -p) (list 0 -p) (list p -p) (list p -p) (list p 1) (list p 1) '( 0 1)
'( 1 2) (list 1 q) (list 1 q) (list -q q) (list -q q) (list -q -2) (list -q -2) '(-1 -2)
'(-1 -2) (list -1 -q) (list -1 -q) (list q -q) (list q -q) (list q 2) (list q 2) '( 1 2)
)
(list 128
(list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
(list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
(list -p q) (list -p -p) (list -p -p) (list q -p)
(list -q q) (list -q -q) (list -q -q) (list q -q)
)
(vl-list* 256 (list -r r) (list r r) (list -r (1+ r)) (list r (1+ r)) c)
(list 512
(list -p -p) (list p -p) (list -p p) (list p p) (list -q -q) (list q -q)
(list q -q) (list -q q) (list -q q) (list q q) (list q q) (list -q -q)
)
(list 2048
(list -p -p) (list p p) (list -p p) (list p -p)
(list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
(list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
(list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
(list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
(list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
)
(list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
)
)
;; Object Snap for grread: Parse Point - Lee Mac
;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
;; str - [str] String representing point input
;; Returns: [lst] Point represented by the given string, else nil
(defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

(defun str->lst ( str / pos )
(if (setq pos (vl-string-position 44 str))
(cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
(list str)
)
)
(if (wcmatch str "`@*")
(setq str (substr str 2))
(setq bpt '(0.0 0.0 0.0))
)
(if
(and
(setq lst (mapcar 'distof (str->lst str)))
(vl-every 'numberp lst)
(< 1 (length lst) 4)
)
(mapcar '+ bpt lst)
)
)
;; Object Snap for grread: Snap Mode - Lee Mac
;; str - [str] Object Snap modifier
;; Returns: [int] Object Snap bit code for the given modifier, else nil
(defun LM:grsnap:snapmode ( str )
(vl-some
(function
(lambda ( x )
(if (wcmatch (car x) (strcat (strcase str t) "*"))
(progn
(princ (cadr x)) (caddr x)
)
)
)
)
'(
("endpoint" " of " 00001)
("midpoint" " of " 00002)
("center" " of " 00004)
("node" " of " 00008)
("quadrant" " of " 00016)
("intersection" " of " 00032)
("insert" " of " 00064)
("perpendicular" " to " 00128)
("tangent" " to " 00256)
("nearest" " to " 00512)
("appint" " of " 02048)
("parallel" " to " 08192)
("none" "" 16384)
)
)
)
;; OLE -> ACI - Lee Mac
;; Args: c - [int] OLE Colour
(defun LM:OLE->ACI ( c )
(apply 'LM:RGB->ACI (LM:OLE->RGB c))
)
;; OLE -> RGB - Lee Mac
;; Args: c - [int] OLE Colour
(defun LM:OLE->RGB ( c )
(mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 8))
)
;; RGB -> ACI - Lee Mac
;; Args: r,g,b - [int] Red, Green, Blue values
(defun LM:RGB->ACI ( r g b / c o )
(if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
(progn
(setq c (vl-catch-all-apply '(lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o))))
(vlax-release-object o)
(if (vl-catch-all-error-p c)
(prompt (strcat "\nError: " (vl-catch-all-error-message c)))
c
)
)
)
)
;; Application Object - Lee Mac
;; Returns the VLA Application Object
(defun LM:acapp nil
(eval (list 'defun 'LM:acapp 'nil (vlax-get-acad-object)))
(LM:acapp)
)
;;----------------------------------------------------------------------;;

 

Edited July 2, 2019 by CADTutor
Moved code to a code block

[hosneyalaa]

Lee Mac Thank you!

excellent work exactly what i needed

 

Take Care.