使用VLA恢复以前的UCS 乐筑天下 - Powered by Discuz! Archiver

Aftertouch 发表于 2022-7-5 16:26:08

使用VLA恢复以前的UCS

大家好，

我正在构建一个代码，它可以实现以下功能：
-当我附加“某物”时，它会将其放置在层XREF\u测试上。
-当前层保持活动状态。
-当我的UCS不是WCS时，它会询问我是否要更改为WCS。

现在问题来了。。。
命令完成后，我希望恢复以前的UCS。

我用红色标记了代码失败的地方。。。

Error: AutoCAD command rejected: "UCS"

使用反应堆时不允许使用“命令”功能。。。
那么我该如何解决这个问题呢？我是如此的接近。。。

;;Command Reactor for Xref/Attachment layer
(if (null myxr-react)
(setq myxr-react (vlr-command-reactor nil '((:vlr-commandwillstart . myxr-swaplayer)
(:vlr-commandended . myxr-restorelayer)
(:vlr-commandcancelled . myxr-restorelayer))))
)

(defun setormakelayer (layn doc)
(if (null (tblsearch "layer" layn))
(vla-add (vla-get-layers doc) layn)
)
(vla-put-lock (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) layn ) :vlax-true)
(setvar "clayer" layn)
(if (zerop (getvar 'worlducs))
(progn
(ASKFORWCS)
(setq wisselnaarwcs 1)
)
)
)

;;commandwillstart callback (reactor commandlist)
(defun myxr-swaplayer (r cl / doc)
(if (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH" "POINTCLOUDATTACH" "COORDINATIONMODELATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF_TEST" doc)
)
(progn
(setormakelayer "XREF_TEST" doc)
)
)
)
)
)

;;commandended callback (reactor commandlist)
(defun myxr-restorelayer (r cl)
(if (and (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH" "POINTCLOUDATTACH" "COORDINATIONMODELATTACH"))(vlr-data r))
(progn
(setvar "clayer" (vlr-data r))
(if (= wisselnaarwcs 1)
(progn
(princ "RESTORE UCS")
(command "UCS" "P")
(setq wisselnaarwcs 0)
)
)
)
(progn
(vlr-data-set r nil)
)
)
)

(defun ASKFORWCS()
(setq reply (ACET-UI-MESSAGE "UCS NAAR WCS? " "UCS system" (+ Acet:YESNO Acet:ICONQuestion)))
;; Yes = 6, No = 7, Cancel = 2
(if (= reply 6)
(progn
(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"))
(setq wisselnaarwcs 1)
)
(progn
(ALERT "Nope")
)
)
(princ)
)

(princ)

Lee Mac 发表于 2022-7-5 16:31:27

请参见此示例。

Aftertouch 发表于 2022-7-5 16:32:44

嘿，李，谢谢你的例子。。。
我试着看看是否可以在代码中插入所需的代码。。。但是你的代码对我来说很难理解。
我如何使其适合我的编码？

我在代码中添加了红色代码，但出现了以下错误：

Error: lisp value has no coercion to VARIANT with this type:((1.87474 4.632 0.0) (0.846936 0.531695 0.0) (-0.531695 0.846936 0.0))

因此，它确实正确存储UCS，但在放置外部参照并引发此错误后，它不会恢复UCS。

;;Command Reactor for Xref/Attachment layer
(if (null myxr-react)
(setq myxr-react (vlr-command-reactor nil '((:vlr-commandwillstart . myxr-swaplayer)
(:vlr-commandended . myxr-restorelayer)
(:vlr-commandcancelled . myxr-restorelayer))))
)

(defun setormakelayer (layn doc)
(if (null (tblsearch "layer" layn))
(vla-add (vla-get-layers doc) layn)
)
(vla-put-lock (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) layn ) :vlax-true)
(setvar "clayer" layn)
(if (zerop (getvar 'worlducs))
(progn
(ASKFORWCS)
)
)
)

;;commandwillstart callback (reactor commandlist)
(defun myxr-swaplayer (r cl / doc)
(if (member (car cl) '("ATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF" doc)
)
(progn
(setormakelayer "XREF" doc)
)
)
)
)
(if (member (car cl) '("XATTACH" "DWFATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-DWG" doc)
)
(progn
(setormakelayer "XREF-DWG" doc)
)
)
)
)
(if (member (car cl) '("IMAGEATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-IMAGE" doc)
)
(progn
(setormakelayer "XREF-IMAGE" doc)
)
)
)
)
(if (member (car cl) '("PDFATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-PDF" doc)
)
(progn
(setormakelayer "XREF-PDF" doc)
)
)
)
)
(if (member (car cl) '("POINTCLOUDATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-POINTCLOUD" doc)
)
(progn
(setormakelayer "XREF-POINTCLOUD" doc)
)
)
)
)
(if (member (car cl) '("COORDINATIONMODELATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-COORDINATIONMODEL" doc)
)
(progn
(setormakelayer "XREF-COORDINATIONMODEL" doc)
)
)
)
)
)

;;commandended callback (reactor commandlist)
(defun myxr-restorelayer (r cl)
(if (and (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH" "POINTCLOUDATTACH" "COORDINATIONMODELATTACH"))(vlr-data r))
(progn
(setvar "clayer" (vlr-data r))
(if (= wisselnaarwcs 1)
(progn
(ALERT "Vergeet niet je UCS terug te zetten!")
(vla-put-activeucs (ucsr:acdoc)(vla-item (vla-get-usercoordinatesystems (ucsr:acdoc)) ucsr:prevucs))
(setq wisselnaarwcs 0)
)
)
)
(progn
(vlr-data-set r nil)
)
)
)

(defun ASKFORWCS()
(setq reply (ACET-UI-MESSAGE "Het huidige coördinaten-stelsel is niet 'World'\nCoördinaten-stelsen aanpassen naar 'World'?" "UCS SYSTEM" (+ Acet:YESNO Acet:ICONQuestion)))
;; Yes = 6, No = 7, Cancel = 2
(if (= reply 6)
(progn
(setq ucsr:prevucs (mapcar 'getvar '(ucsorg ucsxdir ucsydir)))
(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"))
(setq wisselnaarwcs 1)
)
(progn
;(ALERT "Nope")
)
)
(princ)
)

(defun ucsr:acdoc nil
(eval (list 'defun 'ucsr:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(ucsr:acdoc)
)

（普林斯）

Lee Mac 发表于 2022-7-5 16:37:20

在我的代码中，变量ucsr:prevucs存储活动UCS的名称，或者存储定义活动UCS的向量列表（如果未命名）。然后，还原此UCS的代码测试此变量的值是字符串还是列表，并进行相应的操作。在代码中，变量ucsr:prevucs将始终存储向量列表，但是，您正在尝试恢复命名UCS。

Roy_043 发表于 2022-7-5 16:39:49

您不能在reactor回调中使用命令，但可以使用sendcommand方法。我认为它可以用于Aftertouch的代码：
(vla-sendcommand docObject "_UCS _Previous ")

Aftertouch 发表于 2022-7-5 16:44:41

谢谢大家的回复。

我混合了我的代码，李的代码和罗伊的想法，

代码现在真的可以工作了！耶：-）

即使它在命令行中给我带来了一个错误：

Error: Automation Error. Object is referenced by other object(s)

错误是由代码引起的，用红色标记，它抛出错误，但它仍按我的意愿删除UCS。
有没有办法摆脱这个错误？？？

下面是代码：

;;Command Reactor for Xref/Attachment layer
(if (null myxr-react)
(setq myxr-react (vlr-command-reactor nil '((:vlr-commandwillstart . myxr-swaplayer)
(:vlr-commandended . myxr-restorelayer)
(:vlr-commandcancelled . myxr-restorelayer))))
)

(defun setormakelayer (layn doc)
(if (null (tblsearch "layer" layn))
(vla-add (vla-get-layers doc) layn)
)
(vla-put-lock (vla-item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) layn ) :vlax-true)
(setvar "clayer" layn)
(if (zerop (getvar 'worlducs))
(progn
(ASKFORWCS)
)
)
)

;;commandwillstart callback (reactor commandlist)
(defun myxr-swaplayer (r cl / doc)
(setvar "CMDECHO" 0)
(if (member (car cl) '("ATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF" doc)
)
(progn
(setormakelayer "XREF" doc)
)
)
)
)
(if (member (car cl) '("XATTACH" "DWFATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-DWG" doc)
)
(progn
(setormakelayer "XREF-DWG" doc)
)
)
)
)
(if (member (car cl) '("IMAGEATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-IMAGE" doc)
)
(progn
(setormakelayer "XREF-IMAGE" doc)
)
)
)
)
(if (member (car cl) '("PDFATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-PDF" doc)
)
(progn
(setormakelayer "XREF-PDF" doc)
)
)
)
)
(if (member (car cl) '("POINTCLOUDATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-POINTCLOUD" doc)
)
(progn
(setormakelayer "XREF-POINTCLOUD" doc)
)
)
)
)
(if (member (car cl) '("COORDINATIONMODELATTACH"));allowance for other commands
(progn
(setq doc (vlr-document r))
(vlr-data-set r (getvar "clayer"))
(if (= 1 (vla-get-activespace doc))
(progn
(setormakelayer "XREF-COORDINATIONMODEL" doc)
)
(progn
(setormakelayer "XREF-COORDINATIONMODEL" doc)
)
)
)
)
)

;;commandended callback (reactor commandlist)
(defun myxr-restorelayer (r cl)
(if (and (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH" "POINTCLOUDATTACH" "COORDINATIONMODELATTACH"))(vlr-data r))
(progn
(setvar "clayer" (vlr-data r))
(if (= wisselnaarwcs 1)
(progn
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))
(vla-sendcommand doc "_UCS _P ")
(setq wisselnaarwcs 0)
)
(progn
)
)
)
(progn
(vlr-data-set r nil)
)
)
(if (tblsearch "ucs" "WCS")
(progn
(vla-delete (vla-item (vla-get-usercoordinatesystems doc) "WCS"))
)
(progn
)
)
(setvar "CMDECHO" 1)
)

(defun ASKFORWCS()
(setq reply (ACET-UI-MESSAGE "Het huidige coördinaten-stelsel is niet 'World'\nCoördinaten-stelsen aanpassen naar 'World'?" "UCS SYSTEM" (+ Acet:YESNO Acet:ICONQuestion)))
;; Yes = 6, No = 7, Cancel = 2
(if (= reply 6)
(progn
(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.)) "WCS"))
(setq wisselnaarwcs 1 )
)
(progn
;(ALERT "Nope")
)
)
(princ)
)

(princ)

Tharwat 发表于 2022-7-5 16:45:37

你好

你的重复代码太多了！但无论如何，这是我给你的mods，希望它能如你所愿工作。

注意：请尝试新图纸上的代码。

;;Command Reactor for Xref/Attachment layer
(if (null myxr-react)
(setq myxr-react (vlr-command-reactor nil '((:vlr-commandwillstart . myxr-swaplayer)
                                          (:vlr-commandended . myxr-restorelayer)
                                          (:vlr-commandcancelled . myxr-restorelayer)
                                          )
               )
   )
)
;; ;;
(defun setormakelayer (layn doc / lay)
(if (setq lay (vla-add (vla-get-layers doc) layn))
(vla-put-lock lay :vlax-true)
)
(setq *myxrClayer* (getvar 'CLAYER))
(setvar "clayer" layn)
(if (zerop (getvar 'worlducs))
(askforwcs doc)
)
)
;; commandwillstart callback (reactor commandlist)
(defun myxr-swaplayer (r cl / doc cmd)
(setvar "CMDECHO" 0)
(setq doc (vlr-document r)
   cmd (car cl)
   )
(vlr-data-set r (getvar "clayer"))
(cond ((= cmd "ATTACH")                   (setormakelayer "XREF" doc))
   ((member cmd '("XATTACH" "DWFATTACH")) (setormakelayer "XREF-DWG" doc))
   ((= cmd "IMAGEATTACH")             (setormakelayer "XREF-IMAGE" doc))
   ((= cmd "PDFATTACH")                (setormakelayer "XREF-PDF" doc))
   ((= cmd "POINTCLOUDATTACH")          (setormakelayer "XREF-POINTCLOUD" doc))
   ((= cmd "COORDINATIONMODELATTACH") (setormakelayer "XREF-COORDINATIONMODEL" doc))
   )
)
;; commandended callback (reactor commandlist)
(defun myxr-restorelayer (r cl)
(if (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH"
                     "POINTCLOUDATTACH" "COORDINATIONMODELATTACH" ) )
(progn
(and *myxrClayer* (setvar "clayer" *myxrClayer*) (setq *myxrClayer* nil))
(if (= wisselnaarwcs 1)
   (progn
      (vla-sendcommand (vlr-document r) "_UCS _P ")
      (setq wisselnaarwcs 0)
   )
)
)
)
(if (tblsearch "ucs" "WCS")
(vla-delete (vla-item (vla-get-usercoordinatesystems doc) "WCS")
)
)
(setvar "CMDECHO" 1)
)
;; ;;
(defun askforwcs (doc / reply )
(setq reply (acet-ui-message "Het huidige co?rdinaten-stelsel is niet 'World'\nCo?rdinaten-stelsen aanpassen naar 'World'?"
            "UCS SYSTEM" (+ acet:yesno acet:iconquestion))
)
;; Yes = 6, No = 7, Cancel = 2
(if (= reply 6)
(progn
(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.))
            "WCS"
   )
)
(setq wisselnaarwcs 1)
)
;; (ALERT "Nope")
)
(princ)
) (vl-load-com)

Aftertouch 发表于 2022-7-5 16:50:35

嘿Tharwat，

感谢代码中的清理。
这给我带来了一个小错误，但我设法纠正了那个错误。
我用红色标记了它。

现在，您的代码可以像以前一样工作（但现在已清理完毕）：-），但仍然会引发错误：
我这次用绿色标记了原因。：-）
注意：Is仍然完成了我想要的所有事情。。。所以我不明白为什么会出现错误。。。因为它仍然执行delete函数，并实际删除WCS。。。

Error: Automation Error. Object is referenced by other object(s)

;;Command Reactor for Xref/Attachment layer
(if (null myxr-react)
(setq myxr-react (vlr-command-reactor nil '((:vlr-commandwillstart . myxr-swaplayer)
                                          (:vlr-commandended . myxr-restorelayer)
                                          (:vlr-commandcancelled . myxr-restorelayer)
                                          )
               )
   )
)
;; ;;
(defun setormakelayer (layn doc / lay)
(if (setq lay (vla-add (vla-get-layers doc) layn))
(vla-put-lock lay :vlax-true)
)
(setq *myxrClayer* (getvar 'CLAYER))
(setvar "clayer" layn)
(if (zerop (getvar 'worlducs))
(askforwcs doc)
)
)
;; commandwillstart callback (reactor commandlist)
(defun myxr-swaplayer (r cl / doc cmd)
(setvar "CMDECHO" 0)
(setq doc (vlr-document r)
   cmd (car cl)
   )
(vlr-data-set r (getvar "clayer"))
(cond ((= cmd "ATTACH")                   (setormakelayer "XREF" doc))
   ((member cmd '("XATTACH" "DWFATTACH")) (setormakelayer "XREF-DWG" doc))
   ((= cmd "IMAGEATTACH")             (setormakelayer "XREF-IMAGE" doc))
   ((= cmd "PDFATTACH")                (setormakelayer "XREF-PDF" doc))
   ((= cmd "POINTCLOUDATTACH")          (setormakelayer "XREF-POINTCLOUD" doc))
   ((= cmd "COORDINATIONMODELATTACH") (setormakelayer "XREF-COORDINATIONMODEL" doc))
   )
)
;; commandended callback (reactor commandlist)
(defun myxr-restorelayer (r cl)
(if (member (car cl) '("ATTACH" "XATTACH" "IMAGEATTACH" "DWFATTACH" "PDFATTACH"
                     "POINTCLOUDATTACH" "COORDINATIONMODELATTACH" ) )
(progn
(and *myxrClayer* (setvar "clayer" *myxrClayer*) (setq *myxrClayer* nil))
(if (= wisselnaarwcs 1)
   (progn
      (vla-sendcommand (vlr-document r) "_UCS _P ")
      (setq wisselnaarwcs 0)
   )
)
)
)
(if (tblsearch "ucs" "WCS")
(vla-delete (vla-item (vla-get-usercoordinatesystems (vlr-document r)) "WCS") ;replaced doc for (vlr-document r)
)
)
(setvar "CMDECHO" 1)
)
;; ;;
(defun askforwcs (doc / reply )
(setq reply (acet-ui-message "Het huidige co?rdinaten-stelsel is niet 'World'\nCo?rdinaten-stelsen aanpassen naar 'World'?"
            "UCS SYSTEM" (+ acet:yesno acet:iconquestion))
)
;; Yes = 6, No = 7, Cancel = 2
(if (= reply 6)
(progn
(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.))
            "WCS"
   )
)
(setq wisselnaarwcs 1)
)
;; (ALERT "Nope")
)
(princ)
) (vl-load-com)

Tharwat 发表于 2022-7-5 16:52:09

正如预期的那样，我修改过的代码和您在第8篇文章中发布的代码都能正常工作。

Aftertouch 发表于 2022-7-5 16:57:01

嘿Tharwat，

这两个代码似乎都有效，但当我检查命令栏时，我看到了以下内容：

您的代码：

Command: _XATTACH
Overlay Xref "TESTDWG": G:\PROJECTS\TESTDWG.dwg
"TESTDWG" loaded.
Error: bad argument type: VLA-OBJECT nilPress ENTER to continue:
Command: _UCS
Current ucs name:WCS
Specify origin of UCS or <World>: _P
Error: bad argument type: VLA-OBJECT nil

您的代码已修改

Command: _XATTACH
Overlay Xref "TESTDWG": G:\PROJECTS\TESTDWG.dwg
"TESTDWG" loaded.
Error: Automation Error. Object is referenced by other object(s)Press ENTER to continue:
Command: _UCS
Current ucs name:WCS
Specify origin of UCS or <World>: _P

页: [1] 2

乐筑天下's Archiver

使用VLA恢复以前的UCS