'In This Outlook Session...
'I set an appointment to trigger a macro
'to back up local files to the J drive (shared).
Option Explicit
Private Sub Application_Reminder(ByVal Item As Object)
' Backup Files daily @ 5:00 PM
If Item.Subject = "Backup Files" Then
Call BackupFiles
End If
End Sub
'In Module 1...
Option Explicit
Sub BackupFiles()
'This copies all files from a source directory to a target directory that have been changed in the last day,
'including directories and the files within them. This is a recursive copy.
'Note: The target directory structure MUST already exist as a mirror of the source, because this
'macro does not create directories.
'To save time, you should use this to back up only specified folders instead of your entire projects
'folder, or your entire projects folder if it contains only current projects. This is because it
'compares every file it copies, not because it won't work.
'* 5/15/17 Added test for J:\ because telling user the remote drive is not available is
'* better than unhelpful VB errors.
'Soli Deo Gloria.
'(C) Mike Tulloch, 1/10/17, 5/15/17
Dim ObjFSO As New FileSystemObject
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
'The location of the text file that contains the directories to back up.
'The format of the text file is:
'Source path,target path
Const FilePath = "J:\IT TSS\Tulloch\BackupDirs.txt"
Dim OutStr As String
Dim MyLine As String
Dim ts As TextStream
Dim SplitPos As Integer
Dim Length As Integer
'Used to state which dirs have been copied at the end.
'The idea here is that most people will provide just one dir to copy, and it will contain
'all of their files; you don't have to use it that way of course, but that use is typical.
Dim OrigFromPath As String
Dim OrigToPath As String
Dim BadEnd As Boolean
BadEnd = False
OutStr = ""
SplitPos = 0
'Open text file with all the paths to backup.
Set ObjFSO = CreateObject("scripting.filesystemobject")
'If J:\ isn't available, then bail
If ObjFSO.DriveExists(Left$(FilePath, 1)) = False Then
MsgBox "The remote drive (J:\) is not accessible."
BadEnd = True
GoTo OutOfLoop
End If
Set ts = ObjFSO.OpenTextFile(FilePath, ForReading, True)
'Show the progress box.
'ProgressBx.Show
'Read the text file to find paths to backup.
While (Not ts.AtEndOfStream)
MyLine = ts.ReadLine
If (MyLine = "") Then GoTo OutOfLoop
SplitPos = InStr(MyLine, ",")
Length = Len(MyLine)
FromPath = Left(MyLine, SplitPos - 1)
ToPath = Right(MyLine, Length - SplitPos)
OrigFromPath = FromPath
OrigToPath = ToPath
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
If Right(ToPath, 1) <> "\" Then
ToPath = ToPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
'Make sure source dir exists. If it doesn't, then quit.
If FSO.FolderExists(FromPath) = False Then
MsgBox FromPath & " doesn't exist"
BadEnd = True
GoTo OutOfLoop
End If
'Because we know that the source folder exists,
'it is safe to create the target folder if it doesn't exist.
If FSO.FolderExists(ToPath) = False Then
FSO.CreateFolder (ToPath)
End If
Call SearchFolders("", FromPath, ToPath)
Wend
OutOfLoop:
OutStr = ""
'Show status, wrap up, and end
ProgressBx.Hide
If (BadEnd = False) Then
MsgBox "You can find the files from " & OrigFromPath & " in " & OrigToPath
ts.Close
Set ts = Nothing
End If
Set ObjFSO = Nothing
End Sub
'Searches the folders.
Sub SearchFolders(FolderName As String, FromPath As String, ToPath As String)
Dim Fdate As Long
Dim NewFolderName As String
Dim FolderInFromFolder As Object
Dim FSO As Object
Dim Test As Object
'Set From/To paths to current directory
If FolderName <> "" Then
FromPath = FromPath + FolderName + "\"
ToPath = ToPath + FolderName + "\"
End If
'Copy any files that match in the current directory before we change to a new dir.
Call SearchFiles(FromPath, ToPath)
'Set up
Set FSO = CreateObject("scripting.filesystemobject")
On Error GoTo NoMoreFolders
For Each FolderInFromFolder In FSO.GetFolder(FromPath).SubFolders
'Recursively call SearchFolders to explore next folder
NewFolderName = FolderInFromFolder.Name
' Call ProgressBx.Increment(10, (NewFolderName + " "))
Call ProgressBx.Increment(10)
If (NewFolderName <> "") Then Call SearchFolders(NewFolderName, (FromPath), (ToPath))
Next FolderInFromFolder
NoMoreFolders:
Fdate = 0
End Sub
'Searches for files modified either earlier today or yesterday and copies them.
'from FromPath to the ToPath.
Sub SearchFiles(FromPath As String, ToPath As String)
Dim SourceFolder As Object
Dim FileInFromFolder As Object
Dim Fdate As Long
Dim FSO As Object
Dim FSO2 As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set FSO2 = CreateObject("scripting.filesystemobject")
On Error GoTo NoMoreFiles
'Only copy recently changed files
For Each FileInFromFolder In FSO.GetFolder(FromPath).Files
Fdate = FileInFromFolder.DateLastModified
If (Fdate >= CLng(DateAdd("d", -1, Now))) Then
'If folder we're copying to doesn't exist, then let's create it.
'This solves the problem of new folders and the files in them that meet the date
'not getting copied. Now they will.
If Not (FSO2.FolderExists(ToPath)) Then FSO2.CreateFolder (ToPath)
FileInFromFolder.Copy ToPath
'Call ProgressBx.Increment(5, "O")
End If
Next FileInFromFolder
NoMoreFiles:
Fdate = 0
End Sub