Option Explicit
Sub SaveBackup(Optional Book As Workbook)
'Call this macro from the BeforeSave event of the workbook
'Variable declaration
Dim Path As String
Dim FileNoExtension As String
Dim Extension As String
Dim TempFile As String
Dim i As Long
'********
'>>>>>> WINDOWS XP FILE PATH OPTIONS <<<<<<
'Change the following variables
Const History As Long = 3 'Number of old versions of the
'book to save. If set to 0, no old version will be kept
'Hard coded Path value
'Path = "\\Server\apps\"
'Path = "\\Orion\ssapps\99 Temporary Data Storage\David\"
'Path = "C:\"
Path = "C:\TIMESHEETS\"
'Path = "C:\TIMESHEETS\BACKUP FILES\"
'Path = "C:\Documents and Settings\trehearn\My Documents\BACKUP FILES\"
'Path = "C:\Documents and Settings\" & Environ("UserName") & "\Desktop\"
'Path = "C:\Documents and Settings\" & Environ("UserName") & "My Documents\BACKUP FILES\"
'User inputs Path variable
'Path = Range("B1").Value
'********
'********
'>>>>>> WINDOWS 7 FILE PATH OPTIONS <<<<<<
'Don't know if these are correct, just experimentimg as I am unsure if these are different in Windows 7
'Path = "C:\Documents and Settings\" & Environ("UserName") & "\Desktop\"
'Path = "C:\Users\" & Environ("UserName") & "\Desktop\"
'Path = "C:\Users\David\AppData\Roaming\"
'Path = "C:\Users\David\AppData\Roaming\"
'Path = "C:\Users\username\AppData\Roaming\Microsoft\Windows\Templates\"
'********
On Error GoTo err_h
'If we don't have a workbook, assume the active workbook
'If workbook isn't identified, assume the active workbook
If Book Is Nothing Then
Set Book = ActiveWorkbook
End If
'Does the folder exist ?
If Len(Dir$(PathName:=Path, Attributes:=vbDirectory)) = 0 Then
MkDir Path
End If
'Make sure that there is a trailing backslash
If Right$(Path, Len(Application.PathSeparator)) <> _
Application.PathSeparator Then
Path = Path & Application.PathSeparator
End If
If History <= 0 Then
'Don't keep a history, overwrite if the file exists
'Continue if error occurs
On Error Resume Next
SetAttr PathName:=Path & Book.Name, Attributes:=vbNormal
On Error GoTo err_h
Book.SaveCopyAs Path & Book.Name
'Mark it as read only
SetAttr PathName:=Path & Book.Name, Attributes:=vbReadOnly
Else
'Store versions on the path
'First, get the name of the file without the extension
Extension = GetExtension(Book.Name)
FileNoExtension = Left$(Book.Name, _
Len(Book.Name) - Len(Extension) - 1)
'Delete the oldest version available
'Continue if error occurs
On Error Resume Next
SetAttr PathName:=Path & FileNoExtension & "-" & Format$( _
History, "000") & "." & Extension, Attributes:=vbNormal
Kill PathName:=Path & FileNoExtension & "-" & Format$( _
History, "000") & "." & Extension
On Error GoTo err_h
'Now rename any existing older versions
For i = History - 1 To 1 Step -1
'Name of the file being moved
TempFile = Path & FileNoExtension & "-" & Format$(i, _
"000") & "." & Extension
'Does the file exist?
If FileExists(TempFile) Then
'Rename it
Name TempFile As Path & FileNoExtension & "-" & Format$( _
i + 1, "000") & "." & Extension
End If
Next i
'Finally, save the workbook!
Book.SaveCopyAs Path & FileNoExtension & "-001." & Extension
'Mark it as read only
SetAttr PathName:=Path & FileNoExtension & "-001." & _
Extension, Attributes:=vbReadOnly
End If
Exit Sub
err_h:
MsgBox "Error " & Err.Number & ", " & Err.Description, _
vbCritical
End Sub
Function GetExtension(FileName As String) As String
'Variable declaration
Dim i As Long
For i = Len(FileName) To 1 Step -1
If Mid$(FileName, i, 1) = "." Then
GetExtension = Mid$(FileName, i + 1)
Exit Function
End If
Next i
End Function
Function FileExists(sFullName As String) As Boolean
FileExists = Len(Dir(PathName:=sFullName)) > 0
End Function
