'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