[编程交流] “交换”lisp不'；t工作

;  c. 2006 Jeff Rayhorn & LukewarmCoffee.co_
(defun swap ()
(setvar "cmdecho" 0)
(command "undo" "be")
(prompt "\nSelect first group of objects, [ENTER] when done...")
(setq frstset(ssget))
(setq frstpnt(getpoint "\nPick base point for the first group of objects..."))
(prompt "\nSelect second group of objects, [ENTER] when done...")
(setq scndset(ssget))
(setq scndpnt(getpoint "\nPick base point for the second group of objects..."))
(command "move" frstset "" frstpnt scndpnt)
(command "move" scndset "" scndpnt frstpnt)
(command "undo" "e")
(princ)
) 

(defun c:swap (/ *error* Move s1 s2 p1 p2 )
 ;; Lee Mac  ~  12.05.10
 (vl-load-com)
 (defun *error* ( msg )
   (and flag (vla-EndUndoMark doc))
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **")))
   (princ))
 (defun Move ( ss p1 p2 / v1 v2 )
   (mapcar (function set) '(v1 v2)
     (mapcar (function vlax-3D-point) (list p1 p2)))
   
   (
     (lambda ( n / e obj )
       (while (setq e (ssname ss (setq n (1+ n))))
         (if (vlax-method-applicable-p
               (setq obj (vlax-ename->vla-object e)) 'Move)
           (vla-move obj v1 v2)
         )
       )
     )
     -1
   )
 )
 (if
   (and
     (princ "\nSelect First Group of Objects...")
     (setq s1 (ssget "_:L"))
     (setq p1 (getpoint "\nPick First Base Point: "))
     (princ "\nSelect Second Group of Objects...")
     (setq s2 (ssget "_:L"))
     (setq p2 (getpoint "\nPick Second Base Point: "))
     (setq flag
       (not
         (vla-StartUndoMark
           (setq doc
             (vla-get-ActiveDocument
               (vlax-get-acad-object)
             )
           )
         )
       )
     )
   )
   (progn
     (mapcar (function Move)
       (list s1 s2) (list p1 p2) (list p2 p1)
     )
     (setq flag (vla-EndUndomark doc))
   )
 )
 (princ)
)
   

(defun c:EW (/ *error* lst f)
 ;; Entity Swap
 ;; Alan J. Thompson, 06.05.08 / 07.10.08 / 05.01.10
 (defun *error* (msg)
   (and f *AcadDoc* (vla-EndUndoMark *AcadDoc*))
   (and msg
        (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*"))
        (princ (strcat "\nError: " msg))
   )
 )
 (if (and (car (setq lst (cons (car (entsel "\nSelect first object: ")) lst)))
          (cadr (vl-remove nil (setq lst (cons (car (entsel "\nSelect second object: ")) lst))))
     )
   ((lambda (pts)
      (setq f (not (vla-StartUndoMark
                     (cond (*AcadDoc*)
                           ((setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
                     )
                   )
              )
      )
      (mapcar (function (lambda (o a b) (vl-catch-all-apply (function vla-move) (list o a b))))
              (mapcar (function vlax-ename->vla-object) lst)
              pts
              (reverse pts)
      )
    )
     (mapcar (function (lambda (x) (vlax-3d-point (cdr (assoc 10 (entget x))))))
             lst
     )
   )
 )
 (*error* nil)
 (princ)
)