BackUp Automático

Win Vermeer escreveu esta rotina para fazer backup automático do banco de dados. Ela pode ser chamada no evento Ao abrir do seu formulário inicial. Ela cria uma pasta de backup, se não existir, e faz cópias diárias, chamadas Segunda Feira, Terça Feira, etc, que são sobrescritas na semana seguinte. Faz, também, uma cópia semanal.

Dim fs As Object
Dim f As Object
Dim strAppPath As String
Dim strAppName As String
Dim strDay As String
Dim strWeek As String
Dim strDailyBackup As String
Dim strWeeklyBackup As String
Dim boolMakeDailyBackup As Boolean
Dim boolMakeWeeklyBackup As Boolean

    strAppName = Application.CurrentProject.FullName
    strAppPath = Application.CurrentProject.Path
    strBackupPath = strAppPath & "\backup\"
    Set fs = CreateObject("Scripting.FileSystemObject")
    If Not (fs.FolderExists(strBackupPath)) Then fs.CreateFolder (strBackupPath)

' Vamos fazer um backup diário
' Se o arquivo de backup já existe, verificar se tem a data atual.
' Se for, não faz a cópia. Se não for a data atual, exclui o arquivo.
' Copia.

    boolMakeDailyBackup = True
    strDay = Format(Now(), "dddd")
    strDailyBackup = strBackupPath & strDay & ".MDB"

    If fs.FileExists(strDailyBackup) Then
        Set f = fs.GetFile(strDailyBackup)
        If f.DateCreated = Date Then
            boolMakeDailyBackup = False
        Else
            fs.deletefile strDailyBackup
        End If
    End If

' Faz um backup semanal (podem dizer que sou paranóico mas durmo tranquilo)

    If boolMakeDailyBackup Then fs.CopyFile strAppName, strDailyBackup
    boolMakeWeeklyBackup = True
    strWeek = Format(Now(), "yyyy-ww") ' Pega o ano e o número da semana
    strWeeklyBackup = strBackupPath & strWeek & ".MDB"
    If fs.FileExists(strWeeklyBackup) Then
        boolMakeWeeklyBackup = False
    End If
    If boolMakeWeeklyBackup Then fs.CopyFile strAppName, strWeeklyBackup

Saida:
    Exit Sub

FazBackUp_Erro:
    MsgBox "Erro: " & vbCrLf & vbCrLf & Err.Description & vbCrLf & _
           " no procedimento FazBackUp", vbExclamation + vbOKOnly, _
           "Erro: " & CStr(Err.Number)

#If DESENV Then
    Stop
    Resume
#End If
    Resume Saida
    End Sub