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

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

你好
虽然这次我在AutoCAD 2017和之前的AutoCAD 2015上尝试了上面发布的两个代码，但这里没有任何错误。

我为你录制了一段视频，但我无法在这里上传，因为它超过了1.0 MB，所以你不能直接从我的谷歌硬盘从下面的链接下载。

https://drive.google.com/drive/my-drive

Roy_043 发表于 2022-7-5 17:01:12

也许下面的（更干净的）代码工作得更好？所有还原操作都是通过“sendcommand”完成的。请注意，在BricsCAD中，恢复以前的UCS不起作用。似乎使用vla put activeucs打破了UCS的“序列”。
作为替代方案，您可以考虑使用重新定义的命令，而不是反应器。
(vl-load-com)

;;; Command Reactor for Xref/Attachment layer and UCS.
(if (not *MyXr-react*)
(setq *MyXr-react*
(vlr-command-reactor
nil
'(
   (:vlr-commandwillstart . MyXr-CB-Start) ; CB=callback.
   (:vlr-commandended . MyXr-CB-End)
   (:vlr-commandcancelled . MyXr-CB-End)
)
)
)
)

(defun MyXr-CB-Start (rea lst / doc layNme ucsNme)
(if
(vl-position
(car lst)
'(
   "ATTACH"
   "XATTACH"
   "DWFATTACH"
   "IMAGEATTACH"
   "PDFATTACH"
   "POINTCLOUDATTACH"
   "COORDINATIONMODELATTACH"
)
)
(progn
(setq doc (vlr-document rea))
(setq layNme (MyXr-ChangeLayer doc (car lst)))
(setq ucsNme (MyXr-ChangeUcs doc))
(vlr-data-set rea (list layNme ucsNme))
)
(vlr-data-set rea nil)
)
)

(defun MyXr-CB-End (rea lst)
(if (print (vlr-data rea))
(progn
(vla-sendcommand
   (vlr-document rea)
   (strcat
      "(MyXr-Restore "
      (vl-prin1-to-string (car (vlr-data rea))); Layer name.
      " "
      (vl-prin1-to-string (cadr (vlr-data rea))) ; UCS name.
      ") "
   )
)
(vlr-data-set rea nil)
)
)
)

; Returns old layer name.
(defun MyXr-ChangeLayer (doc cmd / layNew layOld)
(setq layNew
(cond
((= cmd "ATTACH")                         "XREF")
((vl-position cmd '("XATTACH" "DWFATTACH")) "XREF-DWG")
((= cmd "IMAGEATTACH")                   "XREF-IMAGE")
((= cmd "PDFATTACH")                      "XREF-PDF")
((= cmd "POINTCLOUDATTACH")             "XREF-POINTCLOUD")
((= cmd "COORDINATIONMODELATTACH")       "XREF-COORDINATIONMODEL")
)
)
(vla-put-lock (vla-add (vla-get-layers doc) layNew) :vlax-true)
(setq layOld (getvar 'clayer))
(setvar 'clayer layNew)
layOld
)

; Returns "WCS" (UCS has been changed to 'World') or "".
(defun MyXr-ChangeUcs (doc / reply)
(cond
((= 1 (getvar 'worlducs))
""
)
(
(/=
   6
   (setq reply
      (acet-ui-message
      "Het huidige UCS is niet 'World'\nUCS aanpassen naar 'World'?"
      "UCS SYSTEM"
      (+ acet:yesno acet:iconquestion)
      )
   )
)
""
)
(T
(vla-put-activeucs
   doc
   (vla-add
      (vla-get-usercoordinatesystems doc)
      (vlax-3d-point '(0.0 0.0 0.0))
      (vlax-3d-point '(1.0 0.0 0.0))
      (vlax-3d-point '(0.0 1.0 0.0))
      "WCS"
   )
)
"WCS"
)
)
)

(defun MyXr-Restore (layNme ucsNme / enm)
(setvar 'clayer layNme)
(if (/= "" ucsNme)
(progn
(setvar 'cmdecho 0)
(command "_.ucs" "_previous")
(setvar 'cmdecho 1)
(if (setq enm (tblobjname "UCS" ucsNme))
   (entdel enm)
)
)
)
(princ)
)

(princ)

Aftertouch 发表于 2022-7-5 17:06:09

嘿，罗伊，
我试着重新定义命令，但这很不稳定。由于某些原因，CAD无法“取消定义”一行中的几个命令。然后向我抛出一个错误。很奇怪。

但你的代码似乎工作得几乎完美
需要制作一个小mod。

已替换：

(if (setq enm (tblobjname "UCS" ucsNme))
(entdel enm)
)

适用于：

(command "_.ucs" "_delete" "WCS")

最后一个问题：
我的命令栏现在显示：

Command: (MyXr-Restore "XREF" "WCS")

可以静音吗？

我试图将“MyXr Restore”的所有代码粘贴到“MyXr CB End”函数中，但Ucs命令再次被拒绝。。。。

谢谢你的帮助！：-）

Roy_043 发表于 2022-7-5 17:10:07

尝试：
(vl-load-com)

;;; Command Reactor for Xref/Attachment layer and UCS.
(if (not *MyXr-rea*)
(setq *MyXr-rea*
(vlr-command-reactor
nil
'(
   (:vlr-commandwillstart . MyXr-CB-Start) ; CB=callback.
   (:vlr-commandended . MyXr-CB-End)
   (:vlr-commandcancelled . MyXr-CB-End)
)
)
)
)

(defun MyXr-CB-Start (rea lst / doc layNme ucsNme)
(if
(vl-position
(car lst)
'(
   "ATTACH"
   "XATTACH"
   "DWFATTACH"
   "IMAGEATTACH"
   "PDFATTACH"
   "POINTCLOUDATTACH"
   "COORDINATIONMODELATTACH"
)
)
(progn
(setq doc (vlr-document rea))
(setq layNme (MyXr-ChangeLayer doc (car lst)))
(setq ucsNme (MyXr-ChangeUcs doc))
(vlr-data-set rea (list layNme ucsNme))
(setvar 'cmdecho 0)
)
(vlr-data-set rea nil)
)
)

(defun MyXr-CB-End (rea lst)
(if (vlr-data rea)
(progn
(vla-sendcommand
   (vlr-document rea)
   (strcat
      "(MyXr-Restore "
      (vl-prin1-to-string (car (vlr-data rea))); Layer name.
      " "
      (vl-prin1-to-string (cadr (vlr-data rea))) ; UCS name.
      ") "
   )
)
(vlr-data-set rea nil)
)
)
)

; Returns old layer name.
(defun MyXr-ChangeLayer (doc cmd / layNew layOld)
(setq layNew
(cond
((= cmd "ATTACH")                         "XREF")
((vl-position cmd '("XATTACH" "DWFATTACH")) "XREF-DWG")
((= cmd "IMAGEATTACH")                   "XREF-IMAGE")
((= cmd "PDFATTACH")                      "XREF-PDF")
((= cmd "POINTCLOUDATTACH")             "XREF-POINTCLOUD")
((= cmd "COORDINATIONMODELATTACH")       "XREF-COORDINATIONMODEL")
)
)
(vla-put-lock (vla-add (vla-get-layers doc) layNew) :vlax-true)
(setq layOld (getvar 'clayer))
(setvar 'clayer layNew)
layOld
)

; Returns "WCS" (UCS has been changed to 'World') or "".
(defun MyXr-ChangeUcs (doc / reply)
(cond
((= 1 (getvar 'worlducs))
""
)
(
(/=
   6
   (setq reply
      (acet-ui-message
      "Het huidige UCS is niet 'World'\nUCS aanpassen naar 'World'?"
      "UCS SYSTEM"
      (+ acet:yesno acet:iconquestion)
      )
   )
)
""
)
(T
(vla-put-activeucs
   doc
   (vla-add
      (vla-get-usercoordinatesystems doc)
      (vlax-3d-point '(0.0 0.0 0.0))
      (vlax-3d-point '(1.0 0.0 0.0))
      (vlax-3d-point '(0.0 1.0 0.0))
      "WCS"
   )
)
"WCS"
)
)
)

(defun MyXr-Restore (layNme ucsNme)
(setvar 'clayer layNme)
(if (/= "" ucsNme)
(progn
(command "_.ucs" "_previous")
(if (tblobjname "UCS" ucsNme)
   (command "_.ucs" "_delete" ucsNme)
)
)
)
(setvar 'cmdecho 1)
(princ)
)

(princ)

Aftertouch 发表于 2022-7-5 17:12:49

嘿，罗伊，

我尝试了完全相同的方法，但它没有使命令栏中的行静音：

Command: (MyXr-Restore "XREF" "WCS")

看起来VLA命令不能静音，我想？？

Roy_043 发表于 2022-7-5 17:15:51

AutoCAD中很可能就是这种情况。在BricsCAD中，vla sendcommand字符串从不回显到命令栏（但在滚动之前的命令时可见）。

Aftertouch 发表于 2022-7-5 17:16:53

啊哈，我明白了，那我就不得不接受了

谢谢你的帮助！

Roy_043 发表于 2022-7-5 17:21:22

你可以试着让回声看起来“更好”：
(vl-load-com)

;;; Command Reactor for Xref/Attachment layer and UCS.
(if (not *MyXr-rea*)
(setq *MyXr-rea*
(vlr-command-reactor
nil
'(
   (:vlr-commandwillstart . MyXr-CB-Start) ; CB=callback.
   (:vlr-commandended . MyXr-CB-End)
   (:vlr-commandcancelled . MyXr-CB-End)
)
)
)
(setq *MyXr-layNme* nil)
(setq *MyXr-ucsNme* nil)
)

(defun MyXr-CB-Start (rea lst / doc)
(if
(vl-position
(car lst)
'(
   "ATTACH"
   "XATTACH"
   "DWFATTACH"
   "IMAGEATTACH"
   "PDFATTACH"
   "POINTCLOUDATTACH"
   "COORDINATIONMODELATTACH"
)
)
(progn
(setq doc (vlr-document rea))
(setq *MyXr-layNme* (MyXr-ChangeLayer doc (car lst)))
(setq *MyXr-ucsNme* (MyXr-ChangeUcs doc))
)
(progn
(setq *MyXr-layNme* nil)
(setq *MyXr-ucsNme* nil)
)
)
)

(defun MyXr-CB-End (rea lst)
(if (and *MyXr-layNme* *MyXr-ucsNme*)
(vla-sendcommand (vlr-document rea) "MyXr-Restore ")
)
)

; Returns old layer name.
(defun MyXr-ChangeLayer (doc cmd / layNew layOld)
(setq layNew
(cond
((= cmd "ATTACH")                         "XREF")
((vl-position cmd '("XATTACH" "DWFATTACH")) "XREF-DWG")
((= cmd "IMAGEATTACH")                   "XREF-IMAGE")
((= cmd "PDFATTACH")                      "XREF-PDF")
((= cmd "POINTCLOUDATTACH")             "XREF-POINTCLOUD")
((= cmd "COORDINATIONMODELATTACH")       "XREF-COORDINATIONMODEL")
)
)
(vla-put-lock (vla-add (vla-get-layers doc) layNew) :vlax-true)
(setq layOld (getvar 'clayer))
(setvar 'clayer layNew)
layOld
)

; Returns "WCS" (UCS has been changed to 'World') or "".
(defun MyXr-ChangeUcs (doc / reply)
(cond
((= 1 (getvar 'worlducs))
""
)
(
(/=
   6
   (setq reply
      (acet-ui-message
      "Het huidige UCS is niet 'World'\nUCS aanpassen naar 'World'?"
      "UCS SYSTEM"
      (+ acet:yesno acet:iconquestion)
      )
   )
)
""
)
(T
(vla-put-activeucs
   doc
   (vla-add
      (vla-get-usercoordinatesystems doc)
      (vlax-3d-point '(0.0 0.0 0.0))
      (vlax-3d-point '(1.0 0.0 0.0))
      (vlax-3d-point '(0.0 1.0 0.0))
      "WCS"
   )
)
"WCS"
)
)
)

(defun c:MyXr-Restore ()
(if (and *MyXr-layNme* *MyXr-ucsNme*)
(progn
(setvar 'clayer *MyXr-layNme*)
(if (/= "" *MyXr-ucsNme*)
   (progn
      (setvar 'cmdecho 0)
      (command "_.ucs" "_previous")
      (if (tblobjname "UCS" *MyXr-ucsNme*)
      (command "_.ucs" "_delete" *MyXr-ucsNme*)
      )
      (setvar 'cmdecho 1)
   )
)
(setq *MyXr-layNme* nil)
(setq *MyXr-ucsNme* nil)
)
)
(princ)
)

(princ)

Grrr 发表于 2022-7-5 17:24:55

@罗伊，小建议缩短几行：

(setq layNew
(cond
((= cmd "ATTACH")                         "XREF")
((vl-position cmd '("XATTACH" "DWFATTACH")) "XREF-DWG")
((= cmd "IMAGEATTACH")                   "XREF-IMAGE")
((= cmd "PDFATTACH")                      "XREF-PDF")
((= cmd "POINTCLOUDATTACH")             "XREF-POINTCLOUD")
((= cmd "COORDINATIONMODELATTACH")       "XREF-COORDINATIONMODEL")
)
)

(setq layNew
(cadr
(assoc cmd '( ("ATTACH" "XREF") ("XATTACH" "XREF-DWG") ("DWFATTACH" "XREF-DWG") ("IMAGEATTACH" "XREF-IMAGE")
("PDFATTACH" "XREF-PDF") ("POINTCLOUDATTACH" "XREF-POINTCLOUD") ("COORDINATIONMODELATTACH" "XREF-COORDINATIONMODEL") ))
)
)

OMEGA-ThundeR 发表于 2022-7-5 17:28:25

我的2美分（我自己的“添加外部参照并恢复当前UCS”命令）。虽然没有那么详细，但它可能是有用的。

(Defun c:xrl (/ huidigelaag xrefbestand)
(setq huidigelaag (getvar "clayer"))
(setq xrefbestand (getfiled "Kies het bestand dat je als Xref wilt gebruiken:" "L:/STARTMAP/_Projecten/" "dwg" 10))
(command "UCS" "Named" "Save" "TEMP-UCS" "Y")
(command "UCS" "world")
(command "-layer" "make" "X-XX-AL-REFERENTIE-G" "")
(command "_-xref" "overlay" xrefbestand '(0 0 0) "1" "1" "0")
(Command "-Layer" "set" huidigelaag "")
(command "UCS" "NAmed" "Restore" "TEMP-UCS")
(princ "\nXref geplaatst.")
)

由于您也是荷兰人，因此这也将外部参照放置在右侧的NLCS标准中。它只适用于DWG文件，但可能可以修改以加载其他文件。
它没有错误处理等等，但在我的情况下，它工作得很好。

需要根据自己的情况更改“startmap”位置，以加快浏览速度。

页: 1 [2]

乐筑天下's Archiver