LISP to Copy Current DWG to Superseded Folder

[cleasc]

Hi all, I'm just starting to get my head around this LISP stuff so apologies in advance.

 

I am after a LISP routine that will copy the current drawing to the Superseded folder under a new folder with todays date.

 

EG.

..\Drawings\Current\10089-S01.dwg

to

..\Drawings\Superseded\2009-10-02\10089-S01.dwg

 

Some people here just don't understand the whole superseded document system so i need to make it as simple as possible for them.

 

Any help or links would be greatly appreciated!!!

[cleasc]

Anyone??? Please...

[SteveK]

It'd be easy enough just copying the file (use vl-file-copy, see the help file or here) and as for making folders, you might try something like:

(vl-mkdir (strcat (getvar "DWGPREFIX") "Superseded\\" (rtos (getvar "CDATE") 2 0)))

For help with folder making see here, here or here.

Hope that at least gets you going. If you get stuck let me know.

[JeepMaster]

I think my thread is what you need. Just change the folder name and take out the loginname and it should do what you're looking for. http://www.cadtutor.net/forum/showthread.php?t=40713

[ronjonp]

Anyone??? Please...

 

Here you go. This one will copy all associated xrefs as well.

 

(defun c:super (/ adoc date dwg n newpath pre msg)
 (vl-load-com)
 (defun msg (str) (princ (strcat "\n<<" str ">>")))
 (setq    dwg    (strcat (setq pre (getvar 'dwgprefix)) (getvar 'dwgname))
   adoc    (vla-get-activedocument (vlax-get-acad-object))
   date    (rtos (getvar "CDATE") 2 0)
   date    (strcat (substr date 1 4) "-" (substr date 5 2) "-" (substr date 7 2))
   newpath    (strcat pre "Superseded\\" date "\\")
 )
 (vl-mkdir (strcat pre "Superseded"))
 (vl-mkdir newpath)
 (if (vl-file-directory-p newpath)
   (progn (if (vl-file-copy dwg (strcat newpath (vl-filename-base dwg) ".dwg"))
        (msg (strcat newpath (vl-filename-base dwg) ".dwg"))
      )
      (vlax-for x (vla-get-filedependencies adoc)
        (if (= (vla-get-feature x) "Acad:XRef")
          (if (vl-file-copy
            (setq n (vla-get-fullfilename x))
            (strcat newpath (vl-filename-base n) ".dwg")
          )
        (msg (strcat newpath (vl-filename-base n) ".dwg"))
          )
        )
      )
   )
   (alert (strcat newpath " NOT CREATED!"))
 )
 (princ)
)

[cleasc]

Thanks all!!!

Will get back to you after I get time to look at it.

[cleasc]

Thanks mate, worked a treat!!!

I just wish I could understand what it all means...

 

Here you go. This one will copy all associated xrefs as well.

 

(defun c:super (/ adoc date dwg n newpath pre msg)
 (vl-load-com)
 (defun msg (str) (princ (strcat "\n<<" str ">>")))
 (setq    dwg    (strcat (setq pre (getvar 'dwgprefix)) (getvar 'dwgname))
   adoc    (vla-get-activedocument (vlax-get-acad-object))
   date    (rtos (getvar "CDATE") 2 0)
   date    (strcat (substr date 1 4) "-" (substr date 5 2) "-" (substr date 7 2))
   newpath    (strcat pre "Superseded\\" date "\\")
 )
 (vl-mkdir (strcat pre "Superseded"))
 (vl-mkdir newpath)
 (if (vl-file-directory-p newpath)
   (progn (if (vl-file-copy dwg (strcat newpath (vl-filename-base dwg) ".dwg"))
        (msg (strcat newpath (vl-filename-base dwg) ".dwg"))
      )
      (vlax-for x (vla-get-filedependencies adoc)
        (if (= (vla-get-feature x) "Acad:XRef")
          (if (vl-file-copy
            (setq n (vla-get-fullfilename x))
            (strcat newpath (vl-filename-base n) ".dwg")
          )
        (msg (strcat newpath (vl-filename-base n) ".dwg"))
          )
        )
      )
   )
   (alert (strcat newpath " NOT CREATED!"))
 )
 (princ)
)

[ronjonp]

Glad it worked out for you.

[woodman78]

That is very cool!! ronjonp.

 

One thing though. Can you modify it so that when you open the drawing in the superseded folder that the xrefs are pointed to that location?

 

Just a thought.

[ronjonp]

That is very cool!! ronjonp.

 

One thing though. Can you modify it so that when you open the drawing in the superseded folder that the xrefs are pointed to that location?

 

Just a thought.

 

Give this one a try...it should open all the copied files in the background and repath them accordingly

 

 

(defun c:super (/     adoc      date       doc        dwg         n          newdwg
       newpath     odbx      pre       v        xrname   msg      time
       rjp-repathxref
          )
 (vl-load-com)
 (defun rjp-repathxref    (doc newpath / blks newpath xrname odbx)
   (setq blks (vla-get-blocks doc))
   (vlax-map-collection
     blks
     (function    (lambda    (x)
         (if (= (vla-get-isxref x) :vlax-true)
           (progn (setq xrname (strcat (vl-filename-base (vla-get-path x))))
              (vla-put-path x (strcat newpath xrname ".dwg"))
              (vl-catch-all-error-p
                (vl-catch-all-apply 'vla-put-name (list x xrname))
              )
           )
         )
       )
     )
   )
   (princ)
 )
 (defun msg (str) (princ (strcat "\n<<" str ">>")))
 (setq    dwg    (strcat (setq pre (getvar 'dwgprefix)) (getvar 'dwgname))
   adoc    (vla-get-activedocument (setq doc (vlax-get-acad-object)))
   date    (rtos (getvar 'cdate) 2 0)
   date    (strcat (substr date 1 4) "-" (substr date 5 2) "-" (substr date 7 2))
   time    (rtos (rem (getvar 'cdate) 1) 2 6)
   time    (strcat (substr time 3 2) "." (substr time 5 2))
   newpath    (strcat pre "Superseded\\" date "\\" time "\\")
   newdwg    (strcat newpath (getvar 'dwgname))
 )
 (vl-mkdir (strcat pre "Superseded"))
 (vl-mkdir (strcat pre "Superseded\\" date))
 (vl-mkdir newpath)
 (if (vl-file-directory-p newpath)
   (progn (setq
        odbx (if (< (setq v (substr (getvar 'acadver) 1 2)) "16")
           (vla-getinterfaceobject doc "ObjectDBX.AxDbDocument")
           (vla-getinterfaceobject doc (strcat "ObjectDBX.AxDbDocument." v))
         )
      )
      (if (vl-file-copy dwg newdwg)
        (progn (msg newdwg)
           (if    (not (vl-catch-all-error-p
                  (vl-catch-all-apply 'vla-open (list odbx newdwg))
                )
           )
             (progn (princ (strcat "\nRepathing - " newdwg))
                (rjp-repathxref odbx newpath)
                (vla-saveas odbx (vla-get-name odbx))
             )
           )
        )
      )
      (vlax-for x (vla-get-filedependencies adoc)
        (if (= (vla-get-feature x) "Acad:XRef")
          (if (vl-file-copy
            (setq n (vla-get-fullfilename x))
            (setq newdwg (strcat newpath (vl-filename-base n) ".dwg"))
          )
        (progn    (msg newdwg)
           (if (not (vl-catch-all-error-p
                  (vl-catch-all-apply 'vla-open (list odbx newdwg))
                )
               )
             (progn (princ (strcat "\nRepathing - " newdwg))
                (rjp-repathxref odbx newpath)
                (vla-saveas odbx (vla-get-name odbx))
             )
           )
        )
          )
        )
      )
      (foreach file (vl-directory-files newpath "*.bak" 1)
        (vl-file-delete (strcat newpath file))
      )
   )
   (alert (strcat newpath " NOT CREATED!"))
 )
 (princ)
)

[woodman78]

Excellent stuff. Did the job perfectly!!

 

THanks

[ronjonp]

Excellent stuff. Did the job perfectly!!

 

THanks

 

Glad to help

[woodman78]

ronjonp,

 

I have been using this for a while to great effect. A couple of things though. Can you make it so that I i run it twice in the one day that it sets up different folders instead of putting it all into the one.

 

The other thing is can you get it to remove the *.bak files as they take up valuable space.

 

Thanks.

[ronjonp]

I updated the code in the previous post. Will delete bak files in the superseded folder. Now the files are placed within a subfolder that is the time (superseded\\date\\time)

[woodman78]

That worked a treat ronjonp.

 

Thanks for that.

[ronjonp]

That worked a treat ronjonp.

 

Thanks for that.

 

Not a problem.

[woodman78]

ronjonp,

 

I have been using the above lisp for a while and it's great. I was wondering if you could modify a version of it that would cause a dialog box to popup and choose a folder to save the drawing in with the xrefs in a subfolder. I was planning on using this for tender drawings so that when the drawing is ready to br printed I could invoke the lisp that would save the drawing to the tender folder with xrefs in a sub folder and re path them.

 

I would appreciate your help on this.

[ronjonp]

ronjonp,

 

I have been using the above lisp for a while and it's great. I was wondering if you could modify a version of it that would cause a dialog box to popup and choose a folder to save the drawing in with the xrefs in a subfolder. I was planning on using this for tender drawings so that when the drawing is ready to br printed I could invoke the lisp that would save the drawing to the tender folder with xrefs in a sub folder and re path them.

 

I would appreciate your help on this.

 

Give this a try:

 

(defun c:super (/	  adoc	    date      dir	doc	  dwg
	n	  newdwg    newpath   odbx	pre	  time
	v	  xrname    xrefpath  rjp-repathallxrefs  msg
	browse2dir
       )
 (vl-load-com)
 (defun browse2dir (message / sh folder result)
   (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application"))
   (setq folder (vlax-invoke-method sh 'browseforfolder 0 message 0))
   (vlax-release-object sh)
   (if	folder
     (progn (setq result (vlax-get-property (vlax-get-property folder 'self) 'path))
     (if (/= (substr result (strlen result)) "\\")
       (setq result (strcat result "\\"))
       result
     )
     )
   )
 )
 (defun rjp-repathallxrefs (doc newpath / blks xrname odbx)
   (setq blks (vla-get-blocks doc))
   (vlax-map-collection
     blks
     (function	(lambda	(x)
	  (if (= (vla-get-isxref x) :vlax-true)
	    (progn (setq xrname (strcat (vl-filename-base (vla-get-path x))))
		   (vla-put-path x (strcat newpath xrname ".dwg"))
		   (vl-catch-all-error-p
		     (vl-catch-all-apply 'vla-put-name (list x xrname))
		   )
	    )
	  )
	)
     )
   )
   (princ)
 )
 (defun msg (str) (princ (strcat "\n<<" str ">>")))
 (setq	dwg  (strcat (setq pre (getvar 'dwgprefix)) (getvar 'dwgname))
adoc (vla-get-activedocument (setq doc (vlax-get-acad-object)))
date (rtos (getvar 'cdate) 2 0)
date (strcat (substr date 1 4) "-" (substr date 5 2) "-" (substr date 7 2))
time (rtos (rem (getvar 'cdate) 1) 2 6)
time (strcat (substr time 3 2) "." (substr time 5 2))
 )
 (if (setq dir (browse2dir "Pick a directory to place files..."))
   (progn
     (setq newpath  (strcat dir "Superseded\\" date "\\" time "\\")
    newdwg   (strcat newpath (getvar 'dwgname))
    xrefpath (strcat newpath "Xrefs\\")
     )
     (vl-mkdir (strcat dir "Superseded"))
     (vl-mkdir (strcat dir "Superseded\\" date))
     (vl-mkdir newpath)
     (vl-mkdir xrefpath)
     (if (vl-file-directory-p newpath)
(progn
  (setq	odbx
	 (if (< (setq v (substr (getvar 'acadver) 1 2)) "16")
	   (vla-getinterfaceobject doc "ObjectDBX.AxDbDocument")
	   (vla-getinterfaceobject doc (strcat "ObjectDBX.AxDbDocument." v))
	 )
  )
  (if (vl-file-copy dwg newdwg)
    (progn (msg newdwg)
	   (if (not (vl-catch-all-error-p
		      (vl-catch-all-apply 'vla-open (list odbx newdwg))
		    )
	       )
	     (progn (princ (strcat "\nRepathing - " newdwg))
		    (rjp-repathallxrefs odbx xrefpath)
		    (vla-saveas odbx (vla-get-name odbx))
	     )
	   )
    )
  )
  (vlax-for x (vla-get-filedependencies adoc)
    (if	(= (vla-get-feature x) "Acad:XRef")
      (if (vl-file-copy
	    (setq n (vla-get-fullfilename x))
	    (setq newdwg (strcat xrefpath (vl-filename-base n) ".dwg"))
	  )
	(progn (msg newdwg)
	       (if (not	(vl-catch-all-error-p
			  (vl-catch-all-apply 'vla-open (list odbx newdwg))
			)
		   )
		 (progn	(princ (strcat "\nRepathing - " newdwg))
			(rjp-repathallxrefs odbx xrefpath)
			(vla-saveas odbx (vla-get-name odbx))
		 )
	       )
	)
      )
    )
  )
  (foreach file	(vl-directory-files newpath "*.bak" 1)
    (vl-file-delete (strcat newpath file))
  )
  (foreach file	(vl-directory-files xrefpath "*.bak" 1)
    (vl-file-delete (strcat xrefpath file))
  )
)
(alert (strcat newpath " NOT CREATED!"))
     )
   )
 )
 (princ)
)

[woodman78]

Thanks ronjonp. The choosing the directory is great. I should have explained that I wanted to transfer the drawing and xrefs folder directly to the selected folder without the superseded and the date. I want to be able to do this for a set of drawings for a stage on a project (tender, construction etc.) so I will use it to transfer a good few drawings to the same directory. I am wondering what is the best way to handle the xrefs in that case. Is it to overwrite or to leave the first one that is transfered?

[ronjonp]

Give this a try:

 

(defun c:super (/	  adoc	    date      dir	doc	  dwg
	n	  newdwg    newpath   odbx	pre	  time
	v	  xrname    xrefpath  rjp-repathallxrefs  msg
	browse2dir
       )
 (vl-load-com)
 (defun browse2dir (message / sh folder result)
   (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application"))
   (setq folder (vlax-invoke-method sh 'browseforfolder 0 message 0))
   (vlax-release-object sh)
   (if	folder
     (progn (setq result (vlax-get-property (vlax-get-property folder 'self) 'path))
     (if (/= (substr result (strlen result)) "\\")
       (setq result (strcat result "\\"))
       result
     )
     )
   )
 )
 (defun rjp-repathallxrefs (doc newpath / blks xrname odbx)
   (setq blks (vla-get-blocks doc))
   (vlax-map-collection
     blks
     (function	(lambda	(x)
	  (if (= (vla-get-isxref x) :vlax-true)
	    (progn (setq xrname (vl-filename-base (vla-get-path x)))
		   (vla-put-path x (strcat newpath xrname ".dwg"))
		   (vl-catch-all-error-p
		     (vl-catch-all-apply 'vla-put-name (list x xrname))
		   )
	    )
	  )
	)
     )
   )
   (princ)
 )
 (defun msg (str) (princ (strcat "\n<<" str ">>")))
 (setq	dwg  (strcat (setq pre (getvar 'dwgprefix)) (getvar 'dwgname))
adoc (vla-get-activedocument (setq doc (vlax-get-acad-object)))
date (rtos (getvar 'cdate) 2 0)
date (strcat (substr date 1 4) "-" (substr date 5 2) "-" (substr date 7 2))
time (rtos (rem (getvar 'cdate) 1) 2 6)
time (strcat (substr time 3 2) "." (substr time 5 2))
 )
 (if (setq dir (browse2dir "Pick a directory to place files..."))
   (progn
     (setq newpath  (strcat dir "Superseded\\" date "\\" time "\\")
    newdwg   (strcat newpath (getvar 'dwgname))
    xrefpath (strcat newpath "Xrefs\\")
     )
     (vl-mkdir (strcat dir "Superseded"))
     (vl-mkdir (strcat dir "Superseded\\" date))
     (vl-mkdir newpath)
     (vl-mkdir xrefpath)
     (if (vl-file-directory-p newpath)
(progn
  (setq	odbx
	 (if (< (setq v (substr (getvar 'acadver) 1 2)) "16")
	   (vla-getinterfaceobject doc "ObjectDBX.AxDbDocument")
	   (vla-getinterfaceobject doc (strcat "ObjectDBX.AxDbDocument." v))
	 )
  )
  (if (vl-file-copy dwg newdwg)
    (progn (msg newdwg)
	   (if (not (vl-catch-all-error-p
		      (vl-catch-all-apply 'vla-open (list odbx newdwg))
		    )
	       )
	     (progn (princ (strcat "\nRepathing - " newdwg))
		    (rjp-repathallxrefs odbx xrefpath)
		    (vla-saveas odbx (vla-get-name odbx))
	     )
	   )
    )
  )
  (vlax-for x (vla-get-filedependencies adoc)
    (if	(= (vla-get-feature x) "Acad:XRef")
      (if (vl-file-copy
	    (setq n (vla-get-fullfilename x))
	    (setq newdwg (strcat xrefpath (vl-filename-base n) ".dwg"))
	  )
	(progn (msg newdwg)
	       (if (not	(vl-catch-all-error-p
			  (vl-catch-all-apply 'vla-open (list odbx newdwg))
			)
		   )
		 (progn	(princ (strcat "\nRepathing - " newdwg))
			(rjp-repathallxrefs odbx xrefpath)
			(vla-saveas odbx (vla-get-name odbx))
		 )
	       )
	)
      )
    )
  )
  (foreach file	(vl-directory-files newpath "*.bak" 1)
    (vl-file-delete (strcat newpath file))
  )
  (foreach file	(vl-directory-files xrefpath "*.bak" 1)
    (vl-file-delete (strcat xrefpath file))
  )
)
(alert (strcat newpath " NOT CREATED!"))
     )
   )
 )
 (princ)
)

 

My advice to you is to use etransmit. No code is needed for what you are trying to do.

Edited July 26, 2010 by ronjonp