[编程交流] 选择中点和端点d

(defun c:mlp ( / p1 p2 l ll p1p p2p a loop g p pp ppp10 pp11 ppp11 )
 (setq p1 (trans (getpoint "\nPick start point") 1 0))
 (setq p2 (trans (getpoint "\nPick end point" (trans p1 0 1)) 1 0))
 (setq l (entmakex (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))))
 (setq ll (entget l))
 (setq ll (subst (cons 10 (mapcar '- p1 (mapcar '- p2 p1))) (assoc 10 ll) ll))
 (entmod ll)
 (entupd l)
 (prompt "\nENTER - continue stretching; ESC - keep drawn line")
 (getstring)
 (setq p1p (list (car (trans p1 0 1)) (cadr (trans p1 0 1)) 0.0))
 (setq p2p (list (car (trans p2 0 1)) (cadr (trans p2 0 1)) 0.0))
 (setq a (angle p1p p2p))
 (setq loop t)
 (while loop
   (setq g (grread t 15 0))
   (if (eq (car g) 5)
     (progn
       (setq p (cadr g))
       (setq pp11 (inters p1p p2p p (polar p (+ a (* 0.5 pi)) 1.0) nil))
       (setq ppp11 (inters (trans p1 0 1) (trans p2 0 1) pp11 (mapcar '+ pp11 '(0.0 0.0 1.0)) nil))
       (setq ppp10 (mapcar '- (trans p1 0 1) (mapcar '- (trans ppp11 0 1) (trans p1 0 1))))
       (setq ll (subst (cons 10 (trans ppp10 1 0)) (assoc 10 ll) ll))
       (setq ll (subst (cons 11 (trans ppp11 1 0)) (assoc 11 ll) ll))
       (entmod ll)
       (entupd l)
       (redraw)
     )
     (setq loop nil)
   )
 )
 (princ)
)

(defun c:Test (/ c g 1p a d)
 ;;    Tharwat .7.May.2014        ;;
 (if (setq c (getpoint "\n Specify Midpoint :"))
   (while (eq (car (setq g (grread t 15 0))) 5)
     (redraw)
     (grvecs (list -3
                   c
                   (setq 1p (polar c
                                   (setq a (angle c (cadr g)))
                                   (setq d (distance c (cadr g)))
                            )
                   )
                   1p
                   (setq 2p (polar 1p (+ a pi) (* d 2.)))
             )
     )
   )
 )
 (if (eq (car g) 3)
   (entmake (list '(0 . "LINE") (cons 10 1p) (cons 11 2p)))
 )
 (redraw)
 (princ)
)

(defun c:mlpp ( / *error* _acapp _getosmode _grX _OLE->ACI _OLE->RGB _RGB->ACI _snap _polarangs _polar _ortho as ape osm g p1 p2 p3 p0 o p s len nlen )
 (vl-load-com)
 (defun *error* ( msg )
   (if ape (setvar 'aperture ape))
   (if as (setvar 'autosnap as))
   (if osm (setvar 'osmode osm))
   (if msg (prompt msg))
   (princ)
 )
 (defun _acapp nil
     (eval (list 'defun '_acapp 'nil (vlax-get-acad-object)))
     (_acapp)
 )
 (defun _getosmode ( os / lst )
     (foreach mode
        '(
             (0001 . "_end")
             (0002 . "_mid")
             (0004 . "_cen")
             (0008 . "_nod")
             (0016 . "_qua")
             (0032 . "_int")
             (0064 . "_ins")
             (0128 . "_per")
             (0256 . "_tan")
             (0512 . "_nea")
             (1024 . "_qui")
             (2048 . "_app")
             (4096 . "_ext")
             (8192 . "_par")
         )
         (if (not (zerop (logand (car mode) os)))
             (setq lst (cons "," (cons (cdr mode) lst)))
         )
     )
     (apply 'strcat (cdr lst))
 )
 (defun _grX ( p s c / -s r j )
     (setq -s (- s)
            r (/ (getvar 'viewsize) (cadr (getvar 'screensize)))
            j p
     )
     (grdraw (mapcar '+ j (list (* r -s) (* r -s))) (mapcar '+ j (list (* r s) (* r s))) c)
     (grdraw (mapcar '+ j (list (* r -s) (* r (1+ -s)))) (mapcar '+ j (list (* r (1- s)) (* r s))) c)
     (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r -s))) (mapcar '+ j (list (* r s) (* r (1- s)))) c)
     
     (grdraw (mapcar '+ j (list (* r -s) (* r s))) (mapcar '+ j (list (* r s) (* r -s))) c)
     (grdraw (mapcar '+ j (list (* r -s) (* r (1- s)))) (mapcar '+ j (list (* r (1- s)) (* r -s))) c)
     (grdraw (mapcar '+ j (list (* r (1+ -s)) (* r s))) (mapcar '+ j (list (* r s) (* r (1+ -s)))) c)
     p
 )
 (defun _OLE->ACI ( c )
     (apply '_RGB->ACI (_OLE->RGB c))
 )
 (defun _OLE->RGB ( c )
     (mapcar '(lambda ( x ) (lsh (lsh (fix c) x) -24)) '(24 16 )
 )
 (defun _RGB->ACI ( r g b / c o )
     (if (setq o (vla-getinterfaceobject (_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
             )
         )
     )
 )
 (defun _snap ( p osm )
   (if (osnap p (_getosmode osm))
     (osnap p (_getosmode osm))
     p
   )
 )
 (defun _polarangs ( ang / n k a l )
   (if (/= ang 0.0)
     (progn
       (setq n (/ 360.1 (cvunit ang "radians" "degrees")))
       (setq k -1.0)
       (repeat (1+ (fix n))
         (setq a (* (setq k (1+ k)) ang))
         (setq l (cons a l))
       )
       l
     )
     (list 0.0)
   )
 )
 (defun _polar ( p0 p flag ang / a b an )
   (if flag
     (progn
       (setq a (car (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
       (setq b (last (vl-sort (_polarangs ang) '(lambda ( a b ) (< a (angle p0 p) b)))))
       (if (< (abs (- (angle p0 p) a)) (abs (- (angle p0 p) b))) (setq an a) (setq an b))
       (inters p0 (polar p0 an 1.0) p (polar p (+ an (* 0.5 pi)) 1.0) nil)
     )
     p
   )
 )
 (defun _ortho ( p0 p flag )
   (if flag
     (_polar p0 p t (* 0.5 pi))
     p
   )
 )
 (setq p1 (getpoint "\nPick or specify mid point : "))
 (setvar 'orthomode 1)
 (setq ape (getvar 'aperture))
 (setvar 'aperture 40)
 (setq as (getvar 'autosnap))
 (setvar 'autosnap 31)
 (setq osm (getvar 'osmode))
 (setvar 'osmode 15359)
 (if (eq (getvar 'orthomode) 1) (setq o t) (setq o nil))
 (if (eq (logand (getvar 'autosnap)  8) (setq p t) (setq p nil))
 (if (eq (logand (getvar 'autosnap) 16) 16) (setq s t) (setq s nil))
 (while (not (or (eq (car (setq g (grread t 15 0))) 3) (eq (car g) 25) (eq (car g) 11)))
   (redraw)
   (if (listp (cadr g)) (setq p2 (cadr g) p3 (cadr g)))
   (cond 
     ( (eq (cadr g) 15)
       (if (eq o t) (setq o nil) (setq o t))
     )
     ( (eq (cadr g) 21)
       (if (eq p t) (setq p nil) (setq p t))
     )
     ( (eq (cadr g) 6)
       (if (eq s t) (setq s nil) (setq s t))
     )
   )
   (cond
     ( (and o p s)
       (setq p2 (_snap (_ortho p1 p2 t) (getvar 'osmode)))
     )
     ( (and o (not p) s)
       (setq p2 (_snap (_ortho p1 p2 t) (getvar 'osmode)))
     )
     ( (and (not o) p s)
       (setq p2 (_snap (_polar p1 p2 t (getvar 'polarang)) (getvar 'osmode)))
     )
     ( (and (not o) (not p) s)
       (setq p2 (_snap p2 (getvar 'osmode)))
     )
     ( (and o p (not s))
       (setq p2 (_ortho p1 p2 t))
     )
     ( (and o (not p) (not s))
       (setq p2 (_ortho p1 p2 t))
     )
     ( (and (not o) p (not s))
       (setq p2 (_polar p1 p2 t (getvar 'polarang)))
     )
     ( (and (not o) (not p) (not s))
       (setq p2 p2)
     )
   )
   (if (not (equal p2 p3 1e-6))
     (_grX p2 (atoi (getenv "AutoSnapSize")) (_OLE->ACI (if (= 1 (getvar 'cvport)) (atoi (getenv "Layout AutoSnap Color")) (atoi (getenv "Model AutoSnap Color")))))
   )
   (setq p0 (mapcar '- p1 (mapcar '- p2 p1)))
   (grdraw p0 p2 1 1)
 )
 (entmake (list '(0 . "LINE") (cons 10 (trans p0 1 0)) (cons 11 (trans p2 1 0))))
 (setq len (distance p0 p2))
 (prompt (strcat "\nCurrent length is : " (rtos len 2 15)))
 (initget 6)
 (setq nlen (getdist (strcat "\nPick or specify new length <" (rtos len 2 15) "> : ")))
 (if nlen (command "_.scale" (entlast) "" "_non" p1 "_R" len nlen))  
 (redraw)
 (*error* nil)
)