[编程交流] 用于Copyalign的Lisp（2次单击）

(defun c:al2p ( / *error* sel_ob get_ends ss e1 e2 l1 l2 p1)
 (vl-load-com)
 (or acDoc (setq acDoc (vla-get-activedocument (vlax-get-acad-object))))
 (vla-startundomark acDoc)
 (defun *error* (msg)
 (and msg (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*,*QUIT*")) (princ (strcat "\nError: ") msg))
 (vla-endundomark acDoc)
 (princ)
 )
 ;********************
 ;sel_obj- prevent selecting the same objects; prompt for missing
 ;return list (ename point)
 (defun sel_ob (p tip msg / e msg1)
 (setvar 'errno 0)
 (if (setq e (entsel msg))
 (if
 (and
 (setq msg1 (strcat "\nFirst element is not " tip))
 (wcmatch (cdr (assoc 0 (entget (car e)))) tip)
 (setq msg1 "\nSecond element must be different than first...")
 (not (eq (car e) p))
 )
 e
 (progn (princ msg1) (sel_ob p tip msg))
 )
 (if (= (getvar 'errno) 7)
 (progn (princ "\nMissed.. Try again.")
 (sel_ob p tip msg)
 )
 nil
 )
 )
 )
 ;********************
 (defun get_ends (e / o p p1 p2 b)
 (setq o (car e)
 b (eq (cdr (assoc 0 (entget o))) "LWPOLYLINE")
 p (vlax-curve-getparamatpoint
 o
 (vlax-curve-getclosestpointto o (trans (cadr e) 1 0))
 )
 p1 (if b
 (fix p)
 (vlax-curve-getstartparam o)
 )
 p2 (if b
 (1+ p1)
 (vlax-curve-getendparam o)
 )
 )
 (if (> (- p2 p) (- p p1))
 (list
 (trans (vlax-curve-getpointatparam o p1) 0 1)
 (trans (vlax-curve-getpointatparam o p2) 0 1)
 )
 (list
 (trans (vlax-curve-getpointatparam o p2) 0 1)
 (trans (vlax-curve-getpointatparam o p1) 0 1)
 )
 )
 )
 ;;; Start main routine
 (while
 (and
 (setq ss (ssget ":L"))
 (setq e1 (sel_ob nil "LINE,LWPOLYLINE" "\nSelect source object: "))
 (setq e2 (sel_ob (car e1) "LINE,LWPOLYLINE" "\nSelect destination object: "))
 )
 (progn
 (setq l1 (get_ends e1)
 l2 (get_ends e2)
 )
 (command "_align" ss ""
 "_non" (car l1)
 "_non" (car l2)
 "_non" (cadr l1)
 "_non" (cadr l2)
 "" "_n"
 )
 t
 )
 )
 (vla-endundomark acDoc)
 (princ)
 )