[编程交流] Autolisp移动函数

(defun C:za (/ pt1 pt2 pt3 z1 z2 z3 z4 zdev1 ss x1 y1 pta ptb )
 (setq pt1 (getpoint "\n Point 1: ")) 
 (setq pt2 (getpoint "\n Point 2: "))
 (setq pt3 (getpoint "\n Point 3: "))
 (setq z1 (caddr pt1))
 (setq z2 (caddr pt2))
 (setq z3 (caddr pt3))
 (setq zdev1 (/ (+ z1 z2 z3) 3))
 (princ (rtos zdev1 2 2))
 (setq ss (ssget "_+.:E:S" '((0 . "AECC_COGO_POINT"))))
 (setq pta (getpoint "Basepoint: "))                        ;;Basepoint of forth point      so i can use the X and Y coordinates
 (setq x1 (car pt1))
 (setq y1 (cadr pt1))
 (setq z4 (/ (+ z1 z2 z3) 3))
 (setq ptb (x1 y1 zdev1))                                ;;trying to add in the averaged Z to set pt2
 (command "move" ss "" pt1 pt2)
 (princ)  
)

(defun C:za (/ pt1 pt2 pt3 z1 z2 z3 z4 zdev1 ss x1 y1 pta ptb )
 (setq pt1 (getpoint "\n Point 1: ")) 
 (setq pt2 (getpoint "\n Point 2: "))
 (setq pt3 (getpoint "\n Point 3: "))
 (setq z1 (caddr pt1))
 (setq z2 (caddr pt2))
 (setq z3 (caddr pt3))
 (setq zdev1 (/ (+ z1 z2 z3) 3))
 (princ (rtos zdev1 2 2))
 (setq ss (ssget "_+.:E:S" '((0 . "AECC_COGO_POINT"))))
 (setq pta (getpoint "Basepoint: "))                        
 (setq x1 (car [color="red"]pta[/color]))
 (setq y1 (cadr [color="red"]pta[/color]))
[color="gray"];;;  (setq z4 (/ (+ z1 z2 z3) 3))[/color]
 (setq ptb ([color="blue"]list[/color] x1 y1 zdev1))                                
 (command "move" ss "" [color="red"]pta ptb[/color])
 (princ)  
)

(vl-load-com)
(defun c:MoveCogoToAverageElevation (/ *error* osnapz pt1 pt2 pt3 average acDoc)
 (defun *error* (msg)
   (and osnapz (setvar 'osnapz osnapz))
   (if acDoc
     (vla-endundomark acDoc)
   )
   (cond ((not msg))                                                   ; Normal exit
         ((member msg '("Function cancelled" "quit / exit abort")))    ; <esc> or (quit)
         ((princ (strcat "\n** Error: " msg " ** ")))                  ; Fatal error, display it
   )
   (princ)
 )
 (if
   (and
     (setq osnapz (getvar 'osnapz))
     (setvar 'osnapz 0)
     (setq pt1 (getpoint "\nSpecify first point: "))
     (not (initget 32))
     (setq pt2 (getpoint pt1 "\nSpecify second point: "))
     (not (initget 32))
     (setq pt3 (getpoint pt2 "\nSpecify tertiary point: "))
     (princ
       (strcat
         "\nSelect COGO points to move to "
         (rtos
           (setq average
                  (/ (apply
                       '+
                       (mapcar (function (lambda (x) (caddr x)))
                               (list pt1 pt2 pt3)
                       )
                     )
                     3
                  )
           )
           2
           2
         )
         " average elevation: "
       )
     )
     (princ)
     (ssget "_:L" '((0 . "AECC_COGO_POINT")))
   )
    (progn
      (vla-startundomark
        (setq acDoc (vla-get-activedocument (vlax-get-acad-object)))
      )
      (vlax-for x (vla-get-activeselectionset acDoc)
        (vla-put-elevation x average)
      )
    )
 )
 (*error* nil)
)