Restore previous UCS using VLA

April 20, 2017

Hey All,

I'm building a code that does the following:

- When i attach 'something' it places it on the layer XREF_TEST.

- The current layer stays active.

- When my UCS is not WCS, it asks me if i want to change to WCS.

Now the problem...

When the command is complete, i want to restore the previous UCS.

I marked the code in RED where my code fails...

Error: AutoCAD command rejected: "UCS"

A 'command' function is not allowed when using reactors...

So how can i solve this? Im so damn close...

;;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
[color="red"]					(princ "RESTORE UCS")
				(command "UCS" "P")[/color]
				(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)

Edited April 20, 2017 by Aftertouch

April 20, 2017

See this example.

April 20, 2017

Hey Lee, thanks for the example...

I've tried to see if i could insert the needed code into my code... but your code is hard to understand for me.

How would i make it fit into my coding?

I added the codes in RED to my code, but this error follows:

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

So it DOES store the UCS correctly, but doesnt recovery it after the XREF is placed and throws me this error.

;;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!")
[color="red"]					(vla-put-activeucs (ucsr:acdoc)(vla-item (vla-get-usercoordinatesystems (ucsr:acdoc)) ucsr:prevucs))[/color]
				(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
[color="red"]			(setq ucsr:prevucs (mapcar 'getvar '(ucsorg ucsxdir ucsydir)))[/color]
 			(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)
)

[color="red"](defun ucsr:acdoc nil
   (eval (list 'defun 'ucsr:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
   (ucsr:acdoc)
)[/color]

(princ)

Edited April 20, 2017 by Aftertouch

April 20, 2017

In my code, the variable ucsr:prevucs stores either the name of the active UCS, or a list of vectors defining the active UCS if unnamed. The code which restores this UCS then tests whether the value of this variable is a string or a list, and operates accordingly. In your code, the variable ucsr:prevucs will always store a list of vectors, however, you are attempting to restore a named UCS.

April 20, 2017

You can't use commands in reactor callbacks but the sendcommand method can be used. I think it can work for Aftertouch's code:

(vla-sendcommand docObject "_UCS _Previous ")

April 21, 2017

Thanks all for the replies.

I mixed both my code, with the code of Lee Mac, and the idea of Roy,

And the code actualy works now! Yay :-)

Even tho it throws me an error in the command line:

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

The error is caused by the code, marked in RED, it throws me the error, but it still deletes the UCS as i want it to.

Any idea's how to get rid of this error???

This is the code now:

;;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)
	)
)
[color="red"]	(if (tblsearch "ucs" "WCS")
	(progn
	(vla-delete (vla-item (vla-get-usercoordinatesystems doc) "WCS"))
	)
	(progn
	)
)[/color]
(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)

April 21, 2017

Hi,

You have too much repeated codes! But anyway here is my mods for you and hope it works as you wish.

NOTE: Please try the codes on new drawing.

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

April 21, 2017

Hey Tharwat,

Thanks for the cleanup in the code.

It threw me a small error, but i managed to fix that one.

I marked it in RED.

Now your code works as it did earlier (but cleaned up now) :-), but still throws me the error:

I marked the cause in GREEN this time. :-)

NOTE: Is still DOES complete all things i want... so i dont understand why it gives the error... as it still executes the delete function, and actualy deletes the 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)
       )
     )
   )
 )
[color="seagreen"]  (if (tblsearch "ucs" "WCS")
     (vla-delete (vla-item (vla-get-usercoordinatesystems [color="red"](vlr-document r)[/color]) "WCS") [color="red"];replaced doc for (vlr-document r)[/color]
   )
 )[/color]
 (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)

April 21, 2017

It works here as expected, the codes that I have modified and the one that you have posted in Post# 8.

April 21, 2017

Hey Tharwat,

Both off the codes seem to work, but when i check the command bar, i see this:

YOUR CODE:

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 [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis] <World>: _P
Error: bad argument type: VLA-OBJECT nil

YOUR CODE MODDED

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 [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis] <World>: _P

April 21, 2017

Hi,

No error at all here although this time I have tried the two posted codes above on AutoCAD 2017 and previously on AutoCAD 2015.

I recorded a video for you but I couldn't upload it here since it's exceeded 1.0 MB so you can't download it from the following link direct from my Google Drive.

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

April 21, 2017

Maybe the (cleaner) code below works better? All the restore operations are done via 'sendcommand'. Note that in BricsCAD restoring the previous UCS does not work. It seems that using vla-put-activeucs breaks the UCS 'sequence'.

As an alternative you might consider working with redefined commands instead of reactors.

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

April 21, 2017

Hey Roy,

I tried working with redefining commands, alto that was very unstable. For some reason CAD cannot 'undefine' a few command in a row. Throws a error at me then. Was very weird.

But your code seems to work almost perfectly

Needed to make a small mod.

replaced:

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

for:

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

One final question:

My commandbar now says:

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

Can this be muted?

I tried to paste all the code of 'MyXr-Restore' into the 'MyXr-CB-End' function, but then the Ucs command gets rejected again....

Thanks for all the help! :-)

Edited April 21, 2017 by Aftertouch

April 21, 2017

Try:

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

April 24, 2017

Hey Roy,

I tried the exact same thing, but it doesnt Mute the line in the command bar:

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

Looks like VLA-command cannot be muted i think??

April 24, 2017

That may well be the case in AutoCAD. In BricsCAD the vla-sendcommand string is never echoed to the Command Bar (but is visible when scrolling through previous commands).

April 24, 2017

Aahh i see, ill have to accept this then. :-)

Thanks for the help!

April 25, 2017

You can try to make the echo look 'nicer':

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

April 25, 2017

@Roy, small suggestion to shorten a few lines:

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

April 25, 2017

My 2 cents (my own 'add Xref and restore current UCS' command). Not as elaborate, but it might be usefull.

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

Since you are Dutch too, this also places the XREF in the right NLCS standard. And it only works with DWG files, but could probably be modded to load other files.

It has no error handling and what not, but in my case it works fine enough.

Need to change the 'startmap' location to your own situation to make browsing quicker.

Restore previous UCS using VLA

Recommended Posts

Aftertouch

Link to comment

Share on other sites

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Lee Mac

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Lee Mac

Link to comment

Share on other sites

Roy_043

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Tharwat

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Tharwat

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Tharwat

Link to comment

Share on other sites

Roy_043

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Roy_043

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Roy_043

Link to comment

Share on other sites

Aftertouch

Link to comment

Share on other sites

Roy_043

Link to comment

Share on other sites

Grrr

Link to comment

Share on other sites

OMEGA-ThundeR

Link to comment

Share on other sites

Join the conversation

Tutorials

Forums

Activity