用于Copyalign的Lisp（2次单击）
大家好！我想知道是否有可能将复制升级功能添加到现有的align代码中，只需单击两次即可执行对齐！我想复制一个图纸的一部分，并迅速对齐他们在不同的线，而不修改我的原始图纸！我想在lisp中选择（复制），选择源行，选择目标行！这可能吗？我发布的代码是由Stefan BMR和marko_ribar共同完成的，非常棒。它来自主题“通过两次单击对齐对象”。非常感谢你！(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)
)
页:
[1]