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

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

本帖最后由 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")))

账号		自动登录	找回密码
密码			注册

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

相关帖子