Jump to content

LISP to Copy Current DWG to Superseded Folder


cleasc

Recommended Posts

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

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

Anyone??? Please...

 

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

 

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

Link to comment
Share on other sites

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. :D

 

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

Link to comment
Share on other sites

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

  • 1 month later...

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.

Link to comment
Share on other sites

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)

Link to comment
Share on other sites

  • 8 months later...

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.

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

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 by ronjonp
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...