namezg 发表于 2012-11-5 21:25:13

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

本帖最后由 namezg 于 2012-11-6 20:42 编辑

删除已命名的当前UCS坐标系lisp方法：
(setq currUCSName (getvar "ucsname"))
(if (/= currUCSName "")
      (command "ucs" "na" "d" currUCSName);(command "ucs" "d" currUCSName)
)
我想知道vlisp如何实现此功能。

goldwheat 发表于 2023-11-28 15:00:37

;对当前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)))
)
)

magicheno 发表于 2023-7-10 00:45:08

感谢大佬分享~

namezg 发表于 2012-11-6 17:08:52

自己顶一下

alin 发表于 2012-11-8 11:03:26

在usercoordinatesystems对象里

namezg 发表于 2012-11-8 20:52:04

本帖最后由 namezg 于 2012-11-8 20:52 编辑

在usercoordinatesystems对象里我知道,可是怎么从在usercoordinatesystems里删除呢？

alin 发表于 2012-11-9 12:26:28


(defun DelUCS (Ucsname)
(vl-load-com)
(if (= (getvar "UCSNAME") UcsName)
    (command "_.UCS" "_W")
)
(vlax-for Ucs        (vla-get-UserCoordinateSystems
                  (vla-get-ActiveDocument (vlax-get-acad-object))
                )
    (if        (= (vla-get-name Ucs) UcsName)
      (vla-delete Ucs)
    )
)
)

namezg 发表于 2012-11-9 18:51:22

这样当前坐标系会被删除，而不是改为未命名，我要求的是改为未命名。

alin 发表于 2012-11-10 20:22:45

(defun DelUCS (Ucsname)
(vl-load-com)
(if (= (getvar "UCSNAME") UcsName)
    (command "_.UCS" "_W")
)
(vlax-for Ucs      (vla-get-UserCoordinateSystems
                  (vla-get-ActiveDocument (vlax-get-acad-object))
                )
    (if      (= (vla-get-name Ucs) UcsName)
      (vla-delete Ucs)
    )
)
(command "_.UCS" "_P")
)

namezg 发表于 2012-11-11 12:03:47

谢谢，不过还不是纯vlisp方法
和我下面的一样
(vl-load-com)
(setq AcadObject(vlax-get-acad-object))
(setq AcadDocument(vla-get-ActiveDocument AcadObject))
(setq UcsSel (vla-get-UserCoordinateSystems AcadDocument))
(setq ucsname "new_ucsname")
(if (not (vl-catch-all-error-p (setq UCSobj (vl-catch-all-apply 'vla-Item (list UcsSel ucsname)))));如果指定UCS坐标系在UCS坐标系统中
        (if (= (vla-get-Name UCSobj) (vlax-invoke AcadDocument 'GetVariable "ucsname"));如果指定UCS坐标系是当前UCS坐标系
                (progn
                        (command "ucs" "w")
                        (vla-Delete UCSobj)
                        (command "ucs" "p")
                )
                (vla-Delete UCSobj)
        )
)

namezg 发表于 2012-11-11 12:05:37

就是不知道(command "ucs" "w") (command "ucs" "p")用vlisp如何表达，看来是办不到的。

alin 发表于 2012-11-11 12:14:19

Lee Mac has this ....

(defun UCSWorld (/ doc tmp)
(setq doc (vla-get-ActiveDocument
            (vlax-get-acad-object)))

(vla-put-ActiveUCS doc
    (vla-add (vla-get-usercoordinatesystems doc)
      (vlax-3D-point '(0. 0. 0.))
      (vlax-3D-point '(1. 0. 0.))
          (vlax-3D-point '(0. 1. 0.)) "TempWord_UCS")))
页: [1] 2
查看完整版本: 删除已命名的当前UCS坐标系的vlisp方法