[Resolvido]Script de Beckup Winrar.

Option Compare Database
Option Explicit

Public Function fncbackup()
Dim booResultado As Boolean
Dim objws As Object
Dim objfs As Object
Dim strOrigem As String
Dim strDestino As String
Dim strDestinoNovo As String
Dim strLocalWinRar As String
Dim compri

On Error GoTo trataerro

'--------------------------------------------------------------------
'AQUI VOCÊ TROCA PARA O CAMINHO E PARA O NOME DO SEU BACK-END
'---------------------------------------------------------------------
strOrigem = "c:\Maestro\Maestro_v5_be.accdb" 
strDestino = "c:\Maestro\backup\Maestro_v5_be" & Format(Date, "ddmmyy") & "-" & Format(Time, "hhmmss") & ".accdb"

Set objfs = CreateObject("Scripting.FileSystemObject")
'-----------------------------
'Realiza uma copia o Back-end
'-----------------------------
objfs.CopyFile strOrigem, strDestino
'---------------------------------------------------------------
'Entra com a senha de acesso do back-end ao compactar e reparar
'--------------------------------------------------------------
Set objws = CreateObject("wscript.shell")
objws.SendKeys "a1234", True
objws.SendKeys "{ENTER}"
strDestinoNovo = Replace(strDestino, "-", "-c")
booResultado = Application.CompactRepair(strDestino, strDestinoNovo, True)
'------------------------------------------
'Deleta a copia do back-end não compactada
'------------------------------------------
If booResultado = True Then FileSystem.Kill strDestino

'------------------------------------
'Empacota o back-end com o Winrar
'------------------------------------
If Len(Dir(Environ("PROGRAMFILES(x86)") & "\Winrar\WinRAR.EXE") & "") > 0 Then
    strLocalWinRar = Environ("programFiles(x86)")
Else
    strLocalWinRar = Environ("programFiles")
End If
compri = Shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Replace(strDestinoNovo, ".accdb", "") & ".rar " & strDestinoNovo, vbHide)

'----------------------------------------------------------------
'Deleta a copia do back-end, sobrando apenas a copia do Winrar
'----------------------------------------------------------------
If booResultado = True Then FileSystem.Kill strDestinoNovo

Set objws = Nothing
Set objfs = Nothing
        
If Len(Dir(Left(strDestino, InStrRev(strDestino, "\")) & "*.log", vbArchive) & "") > 0 Then
    MsgBox "Foi detectado problemas no arquivo de backup." & vbCrLf & _
    vbCrLf & "Entre em contato imediatamente com o administrador do Banco de Dados", vbCritical, "Aviso"
End If

sair:
    DoCmd.Quit acQuitSaveAll
    Exit Function
trataerro:
    MsgBox Err.Number & " - " & Err.Description, vbInformation, "Aviso"
    Resume sair
End Function