Save Backup Copy to Subfolder (Word 2013)

[davis1118]

First off I am not experienced with coding so please go easy with my question and code below because I'm sure there will be much wrong with it. I have more experience with using VBA in Excel and just started "playing" around with Word VBA, so I'm not very familiar with the coding differences. I am using Microsoft Word 2013.

(Everything I am trying to do below I am currently doing with Excel with success, but I cannot figure out the code with Word.

I am trying to create a backup copy of the Word document when I save the file. I want the code to create a subfolder "Archive" in the same directory as the original document, and then save the backup copy in the "Archive" subfolder with the current date in the title. My intent is to have one "master" document that can be linked to, and then the history of changes in the archive folder.

Here is the code I am using.


Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)

Dim folderPath As String
Dim myName As String
Dim ext As String
Dim backupdirectory As String

folderPath = Application.ActiveDocument.Path
myName = Left(ActiveDocument.Name, (InStrRev(ActiveDocument.Name, ".") - 1))
ext = Right(ActiveDocument.Name, Len(ActiveDocument.Name) - InStrRev(ActiveDocument.Name, "."))
backupdirectory = "Archive"

Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(ActiveDocument.Path & "/" & backupdirectory) Then
fso.CreateFolder (ActiveDocument.Path & "/" & backupdirectory)
End If

Dim T As String
T = Format(Now, "ddMmmyy hh mm ss")
ActiveDocument.SaveAs FileName:=folderPath & "\" & backupdirectory & "\" & myName & "_" & T & "." & ext
End Sub

This code is partially working. It creates the "Archive" subfolder and saves the document correctly the first time it's saved. But when the document is saved a second time it creates another subfolder in the first subfolder. In that second subfolder the file name is the first backup file name combined with the second backup name. I am not sure why this is happening. Any help would be appreciated.

Thank you very much.

[SamT]

Make sure which document is open/active when you save it. see ActiveDocument.SaveAs FileName: in your code

In Excel, I use Me.SaveCopyAs "bla bla CDble(Now) bla"

[gmayor]

Unlike Excel, Word doesn't have a SaveAsCopy command, so when you SaveAs the document has the new name, hence the accumulation of folders. Instead of SaveAs, copy the document to the new folder after saving by intercepting the save and saveas commands as below. Or you may find http://www.gmayor.com/SaveInTwoPlacesAddIn.htm useful


Sub FileSaveAs()
On Error Resume Next
Dialogs(wdDialogFileSaveAs).Show
BackupDoc ActiveDocument
lbl_Exit:
Exit Sub
End Sub

Sub FileSave()
On Error Resume Next
ActiveDocument.Save
BackupDoc ActiveDocument
lbl_Exit:
Exit Sub
End Sub

Private Sub BackupDoc(ByVal oDoc As Document)
Dim myName As String
Dim ext As String
Dim T As String
Dim fso As Object
If oDoc.Path = "" Then GoTo lbl_Exit
myName = Left(oDoc.Name, (InStrRev(oDoc.Name, ".") - 1))
ext = Right(oDoc.Name, Len(oDoc.Name) - InStrRev(oDoc.Name, "."))
Set fso = CreateObject("Scripting.FileSystemObject")

If Not fso.FolderExists(oDoc.Path & "\Archive") Then
fso.CreateFolder (oDoc.Path & "\Archive")
End If

T = Format(Now, "ddMmmyy hh mm ss")

fso.CopyFile oDoc.FullName, oDoc.Path & "\Archive\" & myName & "_" & T & "." & ext
lbl_Exit:
Set fso = Nothing
Exit Sub
End Sub

[davis1118]

Wow, this works perfectly! Thank you gmayor. This has been driving me crazy for the past week. I thought for sure I would have to wait at least another week for a solution. Can't thank you enough for the fast reply, and great code!

[SamT]

The only thing is... I like to use a TimeStamp that will display in alpha-temporal order in File Explorers

T = Format(Now, "yymmdd hh mm ss")


When I first started the Bet Angel Project, was using just that as my Archive name.
I discovered that it posed an issue when archiving copies of Archived Documents. I decided that using a Dot in front of the TimeStamp would solve this particular issue.


Sub BackUp_Current_Version()
'Requires Name like StringDotTimeStampDotxls.
Dim sName, sext
sName = Split(Me.Name, ".")(0)
sext = Split(Me.Name, ".")(Ubound(Split(Me.Name, ".")))

Me.SaveAs Me.Path & "\" & sName & "." & CDbl(Now) & "." & sext
End Sub

The Date/Time of File creation and last used is available in any File Explorer, all I want is to see them sorted by Name in Alpha-Temporal order. This lets me start a new Version Name without messing with BackUp_Current_Version. I manually move older Versions to the Archive folder.