LISP to Copy Current DWG to Superseded Folder

[woodman78]

The difference Ronjonp is that I don't want to create an archive with this. I will try to explain myself a bit better.

 

When we start a job we start working on drawings in the "Prelim Drawings" folder. We wonrk on these drawings right up until we are about to plot the drawings for Tender. Just before we plot the drawings for Tender we move them to the Tender folder. We then plot the drawings from there so there are a live set of drawings albeit ringfenced in the Tender folder. They are not an archived set of drawings only for reference. I do encourage the lads in the office to use relative paths for xrefs whihc means that just by using saveas there shouldn't be an issue. But....i know that I have a few rebels here who like to do there own thing no matter how much I try to tell them that I am making things easier for them.

 

This is why I was looking for a lisp like this..

[ronjonp]

Take this line out and it will just use the path you select:

 

newpath (strcat dir "Superseded\\" date "\\" time "\\")

[woodman78]

Thanks ronjonp. I'll give it a try.

[woodman78]

I changed the above line to read (setq newpath dir) and removed the lines to create the superseded folder and the date & time folders within them. Sorted now.

 

Thanks ronjonp.

[ronjonp]

Thanks ronjonp. I'll give it a try.

 

Glad we got it sorted

[cleasc]

Time to resurrect this thread

 

ronjonp's code has been useful for a few years now, but I've moved onto a new job and am hoping someone can help me with some minor tweaks... I've spent hours hunting around for some info to figure this out myself, but to no avail :/

 

Basically, instead of saving a superseded copy of the drawing to relative path I now need to set a specific path (\\SAPAFP01\Groups\Drawings\Superseded\...) and then have it create a dated, then time stamped folder.

 

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

 

If possible, can you also provide an explanation as to what needed changing so I can learn what i was doing wrong???

 

Many thanks in advance!!!

[ronjonp]

Time to resurrect this thread

 

ronjonp's code has been useful for a few years now, but I've moved onto a new job and am hoping someone can help me with some minor tweaks... I've spent hours hunting around for some info to figure this out myself, but to no avail :/

 

Basically, instead of saving a superseded copy of the drawing to relative path I now need to set a specific path (\\SAPAFP01\Groups\Drawings\Superseded\...) and then have it create a dated, then time stamped folder.

 

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

 

If possible, can you also provide an explanation as to what needed changing so I can learn what i was doing wrong???

 

Many thanks in advance!!!

 

To hard code a path do as shown in red below:

 

[color=#ff0000](setq pre "c:\\SAPAFP01\\Groups\\Drawings\\")[/color]
 (setq    dwg    (strcat [i](getvar 'dwgprefix) [/i](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))
 )

Edited July 24, 2012 by SLW210
Added tags!

[cleasc]

Sorry, but it hasn't made any difference.

[ronjonp]

Does you directory structure already exist? ie \SAPAFP01\Groups\Drawings

[cleasc]

Yes, there is a centralised area for all drawings that will not change. Hence the need to have a set location.

So all the routine needs to do is create folders for the date & time, then copy the open drawing and any xrefs to the created folder under:

 

\\Sapafp01\Groups\Drawings\CAD\SUPERSEDED\[DATE]\[TIME]\

[ronjonp]

Give this a try. I've put a couple of comments within the file.

super.lsp

Edited August 6, 2012 by ronjonp

[cleasc]

I really appreciate all your help on this!!!

I got an error message...

c:\SAPAFP01\Groups\Drawings\CAD\Superseded\2012-07-24\07.52\ NOT CREATED!

 

One of ur comments within the file say ur not sure about the UNC path working... the 'GROUPS' folder is mapped if that is easier.

 

G:\Drawings\CAD\Superseded\...\...\

[ronjonp]

I updated the lisp above to use xcopy rather than vl-filecopy. Give it a try and let me know if it works for you.

 

Ron

[cleasc]

I updated the lisp above to use xcopy rather than vl-filecopy. Give it a try and let me know if it works for you.

 

Ron

 

That did the trick. Thanks for all the assistance!!!

[ronjonp]

That did the trick. Thanks for all the assistance!!!

 

Glad we got it sorted

[ronjonp]

Here's a quick update to this code since vla-get-filedependencies was removed from AutoCAD 2018.

(defun c:super (/ *error* dir vars)
 (vl-load-com)
 (defun *error* (msg)
   ;; Reset variables
   (mapcar '(lambda (x) (setvar (car x) (cdr x))) vars)
   (if	(not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
     (princ (strcat "\nError: " msg))
   )
   (princ)
 )
 (vl-mkdir (setq dir (strcat (getvar 'dwgprefix) "Superseded")))
 (vl-mkdir (setq dir (strcat dir "\\" (menucmd "m=$(edtime,0,yyyy-mo-dd)"))))
 (if (findfile dir)
   (progn (setq vars (mapcar '(lambda (x) (cons x (getvar x))) '("cmdecho" "expert" "filedia")))
   (mapcar '(lambda (a b) (setvar (car a) b)) vars '(0 5 0))
   (command "_qsave")
   (command "-etransmit"
	    "Current"
	    "Create"
	    (strcat dir "\\" (vl-filename-base (getvar 'dwgname)))
   )
   (mapcar '(lambda (x) (setvar (car x) (cdr x))) vars)
   )
 )
 (princ)
)

Edited June 19, 2017 by ronjonp

[RenManZ]

I was trying to get this to work in AutoCAD 2018 and just found your updated code with etransmit "very nice".

Now I am trying to add a time or version number suffix so if its used a second time in the same day it won't overwrite the previous one, any help would be appreciated!

 

[ronjonp]

2 hours ago, RenManZ said:

I was trying to get this to work in AutoCAD 2018 and just found your updated code with etransmit "very nice".

Now I am trying to add a time or version number suffix so if its used a second time in the same day it won't overwrite the previous one, any help would be appreciated!

 

Change the menucmd line to this to append the hour and minute to the folder.

(menucmd "m=$(edtime,0,yyyy-mo-dd-hhmm)")

[Steven P]

I think Lee Mac had something somewhere to add a (1), (2) etc. to duplicated file names as you save them with a prefix or suffix which could be altered I think and gives an alternative to adding the time

 

[ronjonp]

54 minutes ago, Steven P said:

I think Lee Mac had something somewhere to add a (1), (2) etc. to duplicated file names as you save them with a prefix or suffix which could be altered I think and gives an alternative to adding the time

 

The code below will make versioned subfolders under the date folder:

(defun c:super (/ *error* dir vars v)
  (vl-load-com)
  (defun *error* (msg)
    ;; Reset variables
    (mapcar '(lambda (x) (setvar (car x) (cdr x))) vars)
    (if	(not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq v 0)
  (vl-mkdir (setq dir (strcat (getvar 'dwgprefix) "Superseded")))
  (vl-mkdir (setq dir (strcat dir "\\" (menucmd "m=$(edtime,0,yyyy-mo-dd)"))))
  (cond
    ((findfile dir)
     (while (findfile (strcat dir "\\V" (itoa (setq v (1+ v))))))
     (vl-mkdir (setq dir (strcat dir "\\V" (itoa v))))
     (if (findfile dir)
       (progn (setq vars (mapcar '(lambda (x) (cons x (getvar x))) '("cmdecho" "expert" "filedia")))
	      (mapcar '(lambda (a b) (setvar (car a) b)) vars '(0 5 0))
	      (command "_qsave")
	      (command "-etransmit"
		       "Current"
		       "Create"
		       (strcat dir "\\" (vl-filename-base (getvar 'dwgname)))
	      )
	      (mapcar '(lambda (x) (setvar (car x) (cdr x))) vars)
       )
     )
    )
  )
  (princ)
)