Backup Interativo

Bom dia!
estou tentando aptar o backup interativo de um colega aqui do forum
mas está dando erro código 70

Olá, veja aqui como devem ser postada as Fotos!
https://www.maximoaccess.com/t32003-como-postar-anexos-e-imagens-no-site-maximoaccess-com

Quanto ao Erro, experimente mandar o Backup para outra pasta do Computado, como por exemplo o Desktop.

Pois esse erro é falta de permissão para Salvar o Arquivo de Backup.

Já o fiz
acontece que crie uma cópia do db e ai da esse erro

Estranho
Mas posta aqui pra eu dar uma olhada!

veja!

Amigo, aqui rodou sem problemas!!!

Sem qualquer erro!

Access 2013 x86

Esse codigo e do Avelino estou testando uma adaptacao. Veja meu topico:

https://www.maximoaccess.com/t32054-backup-compactado-do-be-com-senha

Eu uso o em casa o 2013

na minha maquina não roda !
o que poderia ser?

Ja verificou se a Referência foi ativada?
https://www.maximoaccess.com/t25056-backup-interativo

Qual erro acontece, além do 70?

sim está ativa para no código de erro 70 e fecha

Comente essa linha ( On Error GoTo trataErro ) que esta no Evento no TIMER do Formulario.

Quando der o Erro, clique em Depurar, e veja se Aponta para a linha:
objfs.CopyFile Me!txOrigem, Me!txDestino

do Case 4

Se for, é problema de Falta de Permissão do usuário do Windows para Colar o Arquivo na pasta de destino.

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

na depuração aponta para este comando em vermelho

A sim, esse erro ocorre pq vc não colocou a Função para localizar a pasta...

seria está

Public Function fncLocalizarArquivo()

Dim fd As Office.FileDialog
On Error GoTo trataErro
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
With .Filters
.Clear
.Add "Banco de Dados", "*.accdb", 1
.Add "Todos", "*.*", 2
End With
.Title = "Selecionar Banco de Dados)"
.AllowMultiSelect = False
.InitialFileName = "c:\"
.InitialView = msoFileDialogViewPreview
If .Show Then
fncLocalizarArquivo = .SelectedItems(1)
End If
End With
sair:
Exit Function
trataErro:
fncLocalizarArquivo = ""
Resume sair:
End Function

Não... É outra função que estava logo a Baixo dessa no Modulo:

Código:

Public Function fncLocalizarPasta(strTitulo As String)
Dim fd As Office.FileDialog
On Error GoTo trataerro
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.AllowMultiSelect = False
.ButtonName = "Selecionar"
.InitialFileName = "c:\"
.InitialView = msoFileDialogViewList
'.Title = "Selecione a pasta de destino"
.Title = strTítulo
End With
If fd.Show = -1 Then
    fncLocalizarPasta = fd.SelectedItems(1)
End If
sair:
    Exit Function
trataerro:
    fncLocalizarPasta = ""
    Resume sair:
End Function

não funfa!

Aqui funcionou...

Amigo, se não funcionou, certamente apresentou um erro! Então posta a imagem do erro no depurador... Nos passe todas as informaçoes para que possamos lhe ajudar e chegar de forma mais rápida a uma resolução!

Faltou nos dizer qual erro deu nessa linha!

Não da mais erro
mas continua a não permitir

Veja a Mensagem Nº 11
https://www.maximoaccess.com/t32050-backup-interativo#220611

Com a permissão!

Comigo aparecia essa mesma mensagem. Era falta de permissão para inserir ou excluir algum arquivo da pasta na rede.

Alterei as configurações e funcionou.

Bom pessoal tambem com intuito de adaptar o codigo do Avelino modifiquei o mesmo para que nao necessitasse de uma tabela local no frontEnd.


Entao o codigo do formulario de backup ficou assim

Código:

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 Form_Close()
DoCmd.Quit
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 27 Then
DoCmd.Close
KeyCode = 0
End If

End Sub

Private Sub Form_Open(Cancel As Integer)
'----------------------------------------------------------------------------------
'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

Me!Status.Caption = "Iniciando processo..."
Screen.MousePointer = 11
Me.TimerInterval = 2000
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
        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 = "pastadedestinodobackup") As String
Dim strNomeBackEnd As String
Dim strDestino As String
On Error Resume Next
strDestino = "pastadedestinodobackup" 'Trocar o nome da pasta Backup_DB caso queira
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 = "enderecodobe\nomedobe.accdb" '"Mudar o nome do arquivo.accdb"
End Function
Public Function fncNomeBackEnd() As String
fncNomeBackEnd = "nomedobe.accdb"  'Nome do Banco
End Function

Public Function fncCapturaSenha() As Variant
Dim strPassword

strPassword = "suasenha" 'sugiro utilizar apenas numeros

fncCapturaSenha = strPassword
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


Ainda não resolvi

Veja se ajuda:

Alexandre,

E então após esse tempo, conseguiu resolver?

E então?

Sem retorno????