删除已命名的当前UCS坐标系的vlisp方法

magicheno

感谢大佬分享~

goldwheat

;对当前UCS进行命名视为未命名。
(defun CurrentUCS (/ doc tmp)
    (if (null ucsname# ) (setq ucsname# "Unnamed_UCS_"))
      (progn (setq ucsname (getstring (strcat "\n输入ucs名称前缀< " ucsname# " >")))
       (if (= "" ucsname) (setq ucsname ucsname#)  (setq ucsname# ucsname ))
    )
  (setq doc (vla-get-ActiveDocument
              (vlax-get-acad-object)))
   (setq org (getvar "UCSORG"))
   (setq Xpt (trans (list 1 0 0) 1 0))
   (setq Ypt (trans (list 0 1 0) 1 0))
   (setq u (list (- (car Xpt) (car ORg)) (- (cadr Xpt) (cadr ORg)) (- (caddr Xpt) (caddr ORg))))
   (setq v (list (- (car Ypt) (car ORg)) (- (cadr Ypt) (cadr ORg)) (- (caddr Ypt) (caddr ORg))))
   (setq z (v^v u v));; calculate z vector
   (setq Yptp (mapcar '+ org (v^v z u)))
  (vla-put-ActiveUCS doc
    (vla-add (vla-get-usercoordinatesystems doc)
      (vlax-3D-point org)
        (vlax-3D-point Xpt)
          (vlax-3D-point yptp)
             (strcat ucsname  (menucmd "M=$(edtime,$(getvar,date),YY-MO-DD HH：MM)"))
    )
    )
  )
;; 两个矢量的叉积，参数两个矢量，返回值一个矢量.
(defun v^v (v1 v2)
  (list         (- (* (cadr v1) (caddr v2)) (* (caddr v1) (cadr v2)))
         (- (* (caddr v1) (car v2)) (* (car v1) (caddr v2)))
         (- (* (car v1) (cadr v2)) (* (cadr v1) (car v2)))
  )
)