by Dennis Kennedy (2 Submissions)
Category: Files/File Controls/Input/Output
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Mon 23rd January 2006
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
this program will replicate or mirror a network drive to a local backup directory by only copying modified and new files and deleting files
VBcoders
'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
No comments have been posted about this program will replicate or mirror a network drive to a local backup directory by only copying m. Why not be the first to post a comment about this program will replicate or mirror a network drive to a local backup directory by only copying m.
