[Resolvido]Como fazer backup de Tabelas com senha?

Olá amigos do Fórum!

Vocês tem me ajudado muito indiretamente quando venho aqui pesquisar por uma solução de meus problemas, mas agora preciso de uma ajuda direta. Não sei se tem algo no Fórum, pesquisei mas não encontrei.

Eu tenho um sistema Front-End / Back-End, onde as tabelas do Back estão com senha e no Front eu vinculei as tabelas com as senhas. Para ficar mais protegido, desabilitei a tecla SHIFT e Salvei uma cópia para a extesão ACCDE, assim nesta cópia protejo o VBA.

O que eu preciso agora é o seguinte:

Coloquei uma opção que todas as vezes que fecho o sistema, faço uma cópia do Back-End como backup. Só que não está dando certo pois as tabelas estão com senhas. Preciso que me ajudem a colocar um comando que eu consiga fazer cópias das tabelas com senha.

Vou descrever abaixo o código VBA do backup das tabelas o Back-End:

------------------------------------------------
Private Sub BtSair_Click()

Dim CopiaSegura As Object
Dim Caminho As String
Dim DiaSemana As String

DiaSemana = DatePart("w", Date) 'Faz uma cópia por dia, subscrevendo cada backup uma vez por semana

Caminho = "G:\Meu Drive\BKP" & DiaSemana & ".accdb" 'Nome da pasta e nome de inicio para o banco de backup

If MsgBox("SAIR DO SISTEMA?", vbQuestion + vbYesNo, "ATENÇÃO!") = vbYes Then
Set CopiaSegura = CreateObject("Scripting.FileSystemObject")
CopiaSegura.CopyFile "G:\Meu Drive\BDUSS.accdb", Caminho 'Faz cópia do Front End diariamente ao fechar o sistema
DoCmd.Quit
End If

End Sub
-------------------------------------------------

Se puderem me ajudar ou dar uma ideia mais interessante eu agradeço muito!

Boa noite teria como vc postar parte do seu projeto ou uma copia limpa para podermos te ajuda pois teria que ver como e a estrutura do seu projeto, e como e a senha pois o usandoaccess do avelino tem um backup para isso com back end com senha e tb faz compactado pelo winrar vo te manda o codigo do formulario de backup que eu tenho mais se não ajuda posta teu projeto.
Tendo em vista que se voce usa back end e front end o back end nem precisa fazer backup pois ele demora muito pra cresce so com as tabelas, e quando cresce basta abrir e compactar, ja o front end e propicio a dar problema seja uma queda de energia, um reinicio forçado com o sistema aberto ele corrompe o front end mais nao danifica o back ai basta vc ter uma copia do front e substituir ela pronto.

Option Compare Database
Dim Escala          As Single
Dim Evento          As Byte
Dim objfs           As Object
Dim DestinoNovo     As String
Dim intCont         As Integer
Dim strLocalWinRar  As String
Private Sub Fechar_Click()
DoCmd.Close acForm, "frmBackup", acSaveYes
End Sub

Private Sub btCaminho_Click()
Dim strPasta As String
strPasta = fncLocalizarPasta("Selecione a pasta para o Backup...")
If strPasta = "" Then Exit Sub
Me!txDestino = fncDestinoBackup(strPasta)
End Sub

Private Sub BTOK_Click()
Me.Data_Backup = Date
Me!Status.Caption = "Iniciando processo..."
Screen.MousePointer = 11
Me.TimerInterval = 2000
Me.Usuário = getUsuarioAtual()
Me.Hora_Backup = Time
Me.Realizado = True
End Sub

Private Sub btSair_Click()
DoCmd.Close
End Sub



Private Sub Form_BeforeUpdate(Cancel As Integer)
If Me.NewRecord Then
   '------------------------
   'Auditar novo registro
   '------------------------
   Call fncAuditar(Me.Name, 0, "Backup " & Me!Cód_Backup & " Data " & Me.Data_Backup)
Else
   '-------------------------
   'Auditar registro alterado
   '-------------------------
   Call fncAuditar(Me.Name, 1, "Backup " & Me!Cód_Backup & " Data " & Me.Data_Backup)
End If
End Sub

Private Sub Form_Delete(Cancel As Integer)
'---------------------------
'Auditar registro excluido
'---------------------------
Call fncAuditar(Me.Name, 2, "Backup " & Me!Cód_Backup & " Data " & Me.Data_Backup)
End Sub

Private Sub Form_Load()
Me.Caption = DLookup("[SistemaNome]", "[Configuração]") & "   v:  " & DLookup("[Versão]", "[Configuração]")
End Sub

Private Sub Form_Open(Cancel As Integer)
DoCmd.GoToRecord , , acNewRec
'----------------------------------------------------------------------------------
'Verifica a presença do programa WinRAR
'Grava o caminho na variável strLocalWinRar para ser usado na chamada do programa
'-----------------------------------------------------------------------------------
If Len(Dir(Environ("PROGRAMFILES(x86)") & "\Winrar\WinRAR.EXE") & "") > 0 Then
   strLocalWinRar = Environ("programFiles(x86)")
ElseIf Len(Dir(Environ("PROGRAMFILES") & "\Winrar\WinRAR.EXE") & "") > 0 Then
   strLocalWinRar = Environ("programFiles")
Else
   Me!selWinrar.enabled = False
End If
Me!txOrigem = fncOrigemBackup
Me!txDestino = fncDestinoBackup
End Sub

Private Sub Form_Timer()
'---------------------------------------------------------------------------
'Este código se encontra no evento timer para alimentar a barra de progresso
'---------------------------------------------------------------------------
On Error GoTo trataerro
Evento = Evento + 1
Select Case Evento
   Case 1
       '-------------------------------------------------------------------------
       'Desabilita os botões enquanto a cópia estiver sendo realizada
       'Divide a barra de progresso, que tem um comprimento de 11cm, em 8 pedaços
       '-------------------------------------------------------------------------
       Me!cx1.visible = True
       Me!btFoco.SetFocus
       Me!btCaminho.enabled = False
       Me!BTOK.enabled = False
       Escala = (11.2 * 567) / 8
       Me!cx1.Width = Escala
   Case 2
       Me!cx1.Width = Escala * 2
       Set objfs = CreateObject("Scripting.FileSystemObject")
       Me!Status.Caption = "Verificando Base de Dados..."
   Case 3
       Me!Status.Caption = "Copiando Base de Dados..."
       Me!cx1.Width = Escala * 3
   Case 4
       '----------------------------------------------------------------------------
       'Inicia o processo de cópia simples da base de dados para o destino indicado.
       'Aqui a barra de progresso fica parada até a cópia ser concluída
       '----------------------------------------------------------------------------
       objfs.CopyFile Me!txOrigem, Me!txDestino
   Case 5
       '----------------------------------------------
       'Após a conclusão da cópia o código prossegue
       '----------------------------------------------
       Me!Status.Caption = "Compactando Base de Dados..."
       Me!cx1.Width = Escala * 4
   Case 6
       Dim booResultado As Boolean
       '---------------------------------------------------------------------------------
       'Se a sua base de dados contiver uma senha de acesso, o método compactar e reparar
       'irá solicitá-la.
       '
       'A função do SendKeys é passar a senha no processo sem a intervenção do usuário.
       '
       'A função fncProtegido verifica se a base de dados possui senha e então permite
       'o uso do SendKeys.
       '
       'A função fncCapturSenha captura a senha informada na tabela tblCaminhoBe
       '---------------------------------------------------------------------------------
       If fncProtegido = True Then
           Dim objws As Object
           Set objws = CreateObject("wscript.shell")
          '-------------------------------------------------------------------------------------------
           'verifica se não há outro programa com o foco, como o word, excel ou o bloco de notas.
           'Enqunto o Access não tiver o foco, fica aguardando
           '------------------------------------------------------------------------------------------
           Do While GetFocus <> Me.hwnd
               Call Sleep(500) 'aguarda por meio segundo
               DoEvents
           Loop
           '-------------------------------------------------------------------------------------------
           objws.SendKeys fncCapturaSenha, True
           objws.SendKeys "{ENTER}"
       End If
       '-----------------------------------------------------------------------
       'Observe que está sendo compactado e reparado a copia que foi gerada
       'pelo objfs.CopyFile no destino.
       '
       'É gerado então um outro arquivo, devidamente compactado e reparado, no
       'mesmo local de destino.
       '-----------------------------------------------------------------------
       DestinoNovo = Replace(Me!txDestino, "-", "-c")
       booResultado = Application.CompactRepair(Me!txDestino, DestinoNovo, True)
       '-----------------------------------------------------------------------------
       'O arquivo que foi copiado para o destino, pelo objfs.CopyFile, será excluído,
       'pois só nos interessa o que foi compactado e reparado.
       '-----------------------------------------------------------------------------
       If booResultado = True Then FileSystem.Kill Me!txDestino
       Me!cx1.Width = Escala * 5
       Set objws = Nothing
   Case 7
       '-------------------------------------------------
       'Executa o winrar oculto se este tiver habilitado
       '--------------------------------------------------
       If Me!selWinrar = True Then
           Me!Status.Caption = "Compactando com o Winrar..."
           Dim compri
           compri = Shell(strLocalWinRar & "\Winrar\WinRAR.EXE a " & Chr(34) & Replace(DestinoNovo, ".accdb", "") & ".rar" & Chr(34) & " " & Chr(34) & DestinoNovo & Chr(34), vbHide)
       End If
       Me!cx1.Width = Escala * 6
   Case 8
       If Me!selWinrar = True Then
           '--------------------------------------------------------------------------
           'Enquanto o winrar não completar a tarefa de compactação, o comprimento
           'do arquivo gerado fica em zero. Verifico este comprimento com o FileLen.
           'A barra de progresso vai crescendo gradativamente enquanto o winrar não
           'concluir a tarefa.
           '--------------------------------------------------------------------------
           If FileSystem.FileLen((Replace(DestinoNovo, ".accdb", "") & ".rar ")) = 0 Then
               Evento = 7
               If Me!cx1.Width < (11.2 * 567) Then intCont = intCont + 1
               Me!cx1.Width = (Escala * 7) + (15 * intCont)
           Else
               '----------------------------------------------------
               'Deleto o arquivo que não foi compactado pelo WinRAR
               '----------------------------------------------------
               FileSystem.Kill DestinoNovo
               Me!Status.Caption = "Backup concluído..."
               Screen.MousePointer = 0
               Me!cx1.Width = Escala * 8
               Me.TimerInterval = 3000
           End If
       Else
           Me!Status.Caption = "Backup concluído..."
           Screen.MousePointer = 0
           Me!cx1.Width = Escala * 8
           Me.TimerInterval = 3000
       End If
   Case 9
       Set objfs = Nothing
       '-------------------------------------------------------------------------------------
       'Caso tenha ocorrido uma correção da base de dados, pelo método compactar e reparar
       'é gerado um arquilo de log.
       '
       'Então abre um comunicado, para chamada urgente do adminitrador, que deverá verificar
       'e corrigir a base de dados em uso.
       '-------------------------------------------------------------------------------------
       If Len(Dir(Left(Me!txDestino, InStrRev(Me!txDestino, "\")) & "*.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
       Me.TimerInterval = 0
       Evento = 0
End Select
Sair:
   If Me.TimerInterval = 0 Then DoCmd.Close acDefault
   Exit Sub
trataerro:
   MsgBox err.Number & " - " & err.Description, vbInformation, "Aviso"
   Evento = 0: Screen.MousePointer = 0: Me.TimerInterval = 0
   Resume Sair
End Sub

Private Sub Form_Unload(Cancel As Integer)
If Evento > 0 Then Cancel = True
End Sub

Private Function fncDestinoBackup(Optional Destino As String = "local") As String
Dim strNomeBackEnd As String
Dim strDestino As String
On Error Resume Next
strDestino = Replace(Destino, "local", CurrentProject.Path & "\backup")
If Len(Dir(strDestino, vbDirectory) & "") = 0 Then FileSystem.MkDir (strDestino)
strNomeBackEnd = fncNomeBackEnd
strNomeBackEnd = Left(strNomeBackEnd, InStrRev(strNomeBackEnd, ".accdb") - 1)
strNomeBackEnd = strNomeBackEnd & Format(Date, "ddmmyy") & "-" & Format(Time, "hhmmss") & ".accdb"
fncDestinoBackup = strDestino & "\" & strNomeBackEnd
End Function

Private Function fncOrigemBackup() As String
fncOrigemBackup = DLookup("path_0", "tblCaminhoBe")
End Function
Public Function fncNomeBackEnd() As String
fncNomeBackEnd = DLookup("nomeBE", "tblCaminhoBE")
End Function

Public Function fncCapturaSenha() As Variant
fncCapturaSenha = fncCrip(DLookup("senha", "tblCaminhoBE"), 102030)
End Function

Public Function fncProtegido() As Boolean
Dim bd As DAO.Database
On Error Resume Next
'-------------------------------------------------
'Tento abrir o banco sem passar a senha
'Se o banco tiver a senha irá ocorrer o erro 3031
'-------------------------------------------------
Set bd = OpenDatabase(Me!txDestino, False, False)
If err.Number = 3031 Then
   fncProtegido = True
Else
   bd.Close
End If
Set bd = Nothing
End Function

Obrigado Marcelo3092 pela preciosa ajuda.

Sempre aprendo muito com vocês.

Descobri que o que estava causando o erro que apontei acima é que eu tinha salvado meu BD numa pasta no Google Drive e como minha Internet estava lenta ao pedir para salvar na pasta em questão, sobrepondo o arquivo que já constava lá, dava erro, porque o Drive não tinha feito o download da pasta para meu computador, assim quando o sistema ia fazer o backup não encontrava a pasta e dava erro.

A solução era ou eu espera um tempo até o Drive baixar as pastas e arquivos da nuvem ou eu optava em deixar os arquivos em off-line, assim evitava o erro acima.

Espero que tenham entendido o que aconteceu.

No mais, muito obrigado mais uma vez pela atenção.