[编程交流] 使用VLA恢复以前的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)

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

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

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

(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)

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

(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)

(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") ))
 )
)

(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.")
)