[Resolvido]Compactar/Reparar x Access 2007

Bom dia

Pesquisando aqui no fórum sobr compactar/reparar através do VBA achei um tópico com um código interessante. Tentei fazer alguns testes, porém, quando coloco o mesmo em execução ele acaba fechando o access e não compacta/repara.

O código é este:

Código:

Public Function fncCompactaBanco()
Dim objFSO As Object
Dim objEngine As Object
Dim strLckFile As String
Dim strSrcName As String
Dim strDstName As String
Dim strBe As String
Dim strNovoBe As String
Dim strBackup As String
Dim strPassword As Variant
    ''''''''''''''''''''''''''''''''''''''''''''
    'Créditos: http://maximoaccess.forumeiros.com/t1227-resolvidocompactar-back-end-com-senha

'para fechar os forms menos o form principal
Dim obj As Object
Dim strName As String
    If MsgBox("Compactar e Reparar Banco de dados?", vbQuestion + vbYesNo, "Manutenção") = vbNo Then
        DoCmd.Close
        'Exit Sub
    Else
        For Each obj In Application.CurrentProject.AllForms
            'If obj.Name <> "frm_Foco" Then
                DoCmd.Close acForm, obj.Name, acSaveYes
            'End If
        Next obj
    End If
    ''''''''''''''''''''''''''''''''''''''''''''
    'Carrega as variaveis
    'strLckBE = CurrentProject.Path & "\Banco_be.laccdb" ' se esta m uso
    strBe = CurrentProject.Path & "\SysDoctor_v700_be.accdb" 'original
    strNovoBe = CurrentProject.Path & "\SysDoctor_Compactado.accdb" 'arquivo temporario
    strBackup = CurrentProject.Path & "\SysDoctor_v700_be.Maccdb" 'remover o AC e o M para ativar o Backup
    strPassword = "1a2b3c4d" 'senha do BE 'caso de erro na compactação
    Set objEngine = CreateObject("DAO.DBEngine.120")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Desativado,caso o programa travar este arquivo não é deletado
    'If (objFSO.FileExists(strLckBE)) Then 'confere se o BackEnd não está em uso ...
    'MsgBox "Programa com formulario aberto", vbCritical, "Fechar os formularios"
    'Exit Sub
    'Else
    ' se existir um backup antigo,de um compactação anterior ...
    If (objFSO.FileExists(strBackup)) Then
        objFSO.DeleteFile strBackup
    End If
    'se exitir um arquivo compactado antigo...
    If (objFSO.FileExists(strNovoBe)) Then
        objFSO.DeleteFile strNovoBe
    End If
    'Verifica se o EnergiaNF_be esta na pasta do banco de dados
    If (objFSO.FileExists(strBe)) Then
        objFSO.CopyFile strBe, strBackup ' copia o BE a ser compactado
    Else
        MsgBox "Banco_be não encontrado na pasta do Banco de dados", vbCritical, "Atenção"
    'Exit Sub
    End If
    'verifica se fez uma nova copia do BE antes de compactar
    If (objFSO.FileExists(strBackup)) = True Then
        Else
    MsgBox "Erro na copia do arquivo para Backup. Compactação Cancelada....", vbCritical, "Atenção"
    'Exit Sub
    End If
    ''dbVersion120 = 128
    objEngine.CompactDatabase strBe, strNovoBe, , 128, ";pwd=" & strPassword
    objFSO.DeleteFile strBe ' deleta o BE que está sendo compactado
    objFSO.MoveFile strNovoBe, strBe 'Renomeia o BE compactado com o nome original
    MsgBox "Compactado com sucesso.....", vbInformation, "Manutenção"
    'End If
    'reabre o formulario para novo login
    DoCmd.OpenForm "frm_Login"
End Function



Se alguém puder me ajudar ou dar uma dica, agradeço

Att. Vinicius

Tente assim:

Código:

DBEngine.CompactDatabase "Caminho\Nome do banco.accdb", "Caminho\Nome do banco compactado.accdb", , , ";pwd=senha"

Bom dia Criquio

Fiz o teste como indicou mas realmente não consegui fazer com que funcione. Estou disponibilizando parte do banco., caso tenha mais  alguma dica.

A senha do usuário Admin é admin e a senha do banco 1a2b3c. Criei um formulário chamado frm_compactar com o botão compactar que chama a função que está no módulo mod_ajustabanco.

Sel

Obrigado,

Problema resolvido.

Grato pelo retorno. O fórum agradece.