• Home
 · 
• Files/File Controls/Input/Output
 · 
• this program will replicate or mirror a network drive to a local backup directory by only copying m

this program will replicate or mirror a network drive to a local backup directory by only copying m

this program will replicate or mirror a network drive to a local backup directory by only copying modified and new files and deleting files

Rate this program will replicate or mirror a network drive to a local backup directory by only copying m

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

'to a local backup directory by only copying modified
'and new files and deleting files from the backup that
'have been deleted on the network drive. it runs 24-7.
'by Dennis Kennedy
' http://www.geocities.com/dkblid
' mailto:[email protected]

'create a new vb module and paste all of this code into it.
'then modify (primarily, these CONST) to suit your needs.

Option Explicit
Public Const NETWORK_DRIVE = "y:"
Public Const NETWORK_BACKUP = "c:\backup"
Public Const NETWORK_EXIST_FILE = "\bu.exe"

Public Sub Main()
    If App.PrevInstance Then
        End
    End If
    On Error Resume Next
    MkDir NETWORK_BACKUP
    Do
        Call CopyFiles(NETWORK_DRIVE) 'copy files in dir
        Call FindSubFolders(NETWORK_DRIVE)
        Call DeleteFiles(NETWORK_BACKUP) 'delete not found files
        Call FindSubFolders(NETWORK_BACKUP)
    Loop
End Sub

Private Sub FindSubFolders(ByVal sNetworkPath As String)
    Dim fso As Object
    Dim f, f1, sf, d, dc
    On Error GoTo myerrorfolder
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dc = fso.drives
    For Each d In dc 'recheck that the network drive is mapped
        DoEvents
        If LCase(d.Path) = NETWORK_DRIVE Then
            DoEvents
            Set f = fso.GetFolder(sNetworkPath)
            Set sf = f.SubFolders 'find sub folders / directories
            For Each f1 In sf
                DoEvents
                If InStr(LCase(sNetworkPath), NETWORK_DRIVE) > 0 Then
                    Call CopyFiles(f1.Path) 'copy files in dir
                ElseIf InStr(LCase(sNetworkPath), NETWORK_BACKUP) > 0 Then
                    Call DeleteFiles(f1.Path) 'delete not found files
                End If
                Call FindSubFolders(f1.Path)  'recall to get the sub folders
            Next
            Exit For
        End If
    Next
    Exit Sub
myerrorfolder:
    Call WriteErr("Folder: " + sNetworkPath)
    Resume Next
End Sub

Private Sub CopyFiles(ByVal sNetworkPath As String)
    Dim sFileName As String
    Dim sFilePath As String
    Dim sModTime1 As String
    Dim sModTime2 As String
    Dim fso As Object
    On Error GoTo myerrorcopy
    Set fso = CreateObject("Scripting.FileSystemObject")
    sFilePath = NETWORK_BACKUP + Mid(sNetworkPath, Len(NETWORK_DRIVE) + 1)
    If Not fso.folderExists(sFilePath) Then
        fso.createfolder (sFilePath)
    End If
    sFileName = Dir(sNetworkPath + "\")
    DoEvents
    While sFileName <> ""
        DoEvents
        sModTime1 = FileDateTime(sNetworkPath & "\" & sFileName)
        sModTime2 = ""
        sModTime2 = FileDateTime(sFilePath & "\" & sFileName)
        If sModTime1 <> sModTime2 Then
            FileCopy sNetworkPath & "\" & sFileName, sFilePath & "\" & sFileName
        End If
        sFileName = Dir
    Wend
    Exit Sub
myerrorcopy:
    Call WriteErr("Copy: " + sNetworkPath & "\" & sFileName + " to " + sFilePath & "\" & sFileName)
    Resume Next
End Sub

Private Sub DeleteFiles(ByVal sBackupPath As String)
    Dim sFileName As String
    Dim sFilePath As String
    Dim sModTime As String
    Dim fso As Object
    Dim d, dc
    On Error GoTo myerrordelete
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set dc = fso.drives
    If InStr(LCase(sBackupPath), NETWORK_DRIVE) > 0 Then
        'sanity check - don't delete from the network drive
        Exit Sub
    End If
    If InStr(LCase(sBackupPath), NETWORK_BACKUP) = 0 Then
        'sanity check - only delete from the backup drive / directory
        Exit Sub
    End If
    For Each d In dc 'recheck that the network drive is mapped
        DoEvents
        If LCase(d.Path) = NETWORK_DRIVE Then
            sFilePath = NETWORK_DRIVE + Mid(sBackupPath, Len(NETWORK_BACKUP) + 1)
            sFileName = Dir(sBackupPath + "\")
            DoEvents
            While sFileName <> ""
                DoEvents
                sModTime = ""
                sModTime = FileDateTime(sFilePath & "\" & sFileName)
                If sModTime = "" Then 'the network file no longer exists.
                    'make absolutely sure that the network drive is connected.
                    'the network drive may be mapped but is now disconnected.
                    'so, to insure connection before comparison deletion,
                    'compare 'sModTime' with a knowingly existing network file.
                    sModTime = FileDateTime(NETWORK_DRIVE & NETWORK_EXIST_FILE)
                    If sModTime = "" Then
                        'if the 'NETWORK_EXIST_FILE' file does not exist,
                        'assume the network is disconnected before deletion.
                        Exit Sub
                    End If
                    Kill sBackupPath & "\" & sFileName
                End If
                sFileName = Dir
            Wend
            Exit For
        End If
    Next
    Exit Sub
myerrordelete:
    Call WriteErr("Delete: " + sBackupPath & "\" & sFileName)
    Resume Next
End Sub

Private Sub WriteErr(ByVal sString As String)
    Dim nff As Integer
    If Err.Number <> 53 And Err.Number <> 70 And Err.Number <> 75 And Err.Number <> 76 Then
        '53=File Not Found
        '70=Permission Denied
        '75=Path/File access error
        '76=Path Not Found
        nff = FreeFile
        Open App.Path + "\" + App.EXEName + ".err" For Append As #nff
        Print #nff, sString + ":" + LTrim(Str(Err.Number)) + ":" + Err.Description
        Close #nff
    End If
End Sub