MS Access: cómo compactar la base de datos actual en VBA

Question

Pregunta bastante simple, lo sé.

Answer 1

Si desea compactar/reparar un archivo MDB externa (no el que se está trabajando en este momento):

Application.compactRepair sourecFile, destinationFile 

Si desea compactar la base de datos que está trabajando:

Application.SetOption "Auto compact", True 

En este último caso, su aplicación se compactará al cerrar el archivo.

Mi opinión: escribir algunas líneas de código en un archivo "compacter" de MDB extra que puede llamar cuando quiere compactar/reparar un archivo mdb es muy útil: en la mayoría de las situaciones, el archivo que necesita compactar no puede ya no se abre normalmente, por lo que debe llamar al método desde fuera del archivo.

De lo contrario, el autocompacto se establecerá de manera predeterminada en verdadero en cada módulo principal de una aplicación de Access.

En caso de desastre, cree un nuevo archivo mdb e importe todos los objetos del archivo con errores. Por lo general, encontrará un objeto defectuoso (formulario, módulo, etc.) que no podrá importar.

Answer 2

Echa un vistazo a esta solución VBA Compact Current Database.

Básicamente dice que esto debería funcionar

Public Sub CompactDB() 
    CommandBars("Menu Bar").Controls("Tools").Controls ("Database utilities"). _ 
    Controls("Compact and repair database...").accDoDefaultAction 
End Sub 

Answer 3

Sí, es fácil de hacer.

Sub CompactRepair() 
    Dim control As Office.CommandBarControl 
    Set control = CommandBars.FindControl(Id:=2071) 
    control.accDoDefaultAction 
End Sub 

Básicamente solo encuentra el elemento de menú "Compactar y reparar" y hace clic en él, programáticamente.

Answer 4

Lo hice hace muchos años en 2003 o posiblemente 97, ¡sí!

Si no recuerdo mal, necesita utilizar uno de los subcomandos arriba vinculados a un temporizador. No puede operar en el db con conexiones o formularios abiertos.

Por lo tanto, debe hacer algo para cerrar todos los formularios y poner en marcha el temporizador como el último método en ejecución. (que a su vez llamará a la operación compacta una vez que todo se cierre)

Si no se ha enterado de esto, podría buscar en mis archivos y sacarlo.

Answer 5

Cuando el usuario sale del intento de FE para cambiar el nombre de la base de datos MDB preferiblemente con la fecha de hoy en el nombre en formato aaa-mm-dd. Asegúrese de cerrar todos los formularios enlazados, incluidos los formularios ocultos, y los informes antes de hacer esto. Si aparece un mensaje de error, ¡ay !, está ocupado, así que no te molestes. Si tiene éxito, cópielo de nuevo.

Consulte mi Backup, do you trust the users or sysadmins? página de consejos para obtener más información.

Answer 6

También está el SOON ("Shut One, Open New") add-in de Michael Kaplan. Tendría que encadenarlo, pero es una forma de hacerlo.

No puedo decir que haya tenido muchas razones para querer hacer esto programáticamente, ya que estoy programando para usuarios finales, y nunca usan nada más que la interfaz en la interfaz de usuario de Access, y hay no hay razón para compactar regularmente un frente diseñado apropiadamente.

Answer 7

fuente DBEngine.CompactDatabase, dest

Answer 8

Si usted tiene la base de datos con un extremo delantero y un extremo trasero. Se puede utilizar el siguiente código en el formulario principal de su extremo forma la navegación principal frontal:

Dim sDataFile As String, sDataFileTemp As String, sDataFileBackup As String 
Dim s1 As Long, s2 As Long 

sDataFile = "C:\MyDataFile.mdb" 
sDataFileTemp = "C:\MyDataFileTemp.mdb" 
sDataFileBackup = "C:\MyDataFile Backup " & Format(Now, "YYYY-MM-DD HHMMSS") & ".mdb" 

DoCmd.Hourglass True 

'get file size before compact 
Open sDataFile For Binary As #1 
s1 = LOF(1) 
Close #1 

'backup data file 
FileCopy sDataFile, sDataFileBackup 

'only proceed if data file exists 
If Dir(sDataFileBackup vbNormal) <> "" Then 

     'compact data file to temp file 
     On Error Resume Next 
     Kill sDataFileTemp 
     On Error GoTo 0 
     DBEngine.CompactDatabase sDataFile, sDataFileTemp 

     If Dir(sDataFileTemp, vbNormal) <> "" Then 
      'delete old data file data file 
      Kill sDataFile 

      'copy temp file to data file 
      FileCopy sDataFileTemp, sDataFile 

      'get file size after compact 
      Open sDataFile For Binary As #1 
      s2 = LOF(1) 
      Close #1 

      DoCmd.Hourglass False 
      MsgBox "Compact complete " & vbCrLf & vbCrLf _ 
       & "Size before: " & Round(s1/1024/1024, 2) & "Mb" & vbCrLf _ 
       & "Size after: " & Round(s2/1024/1024, 2) & "Mb", vbInformation 
     Else 
      DoCmd.Hourglass False 
      MsgBox "ERROR: Unable to compact data file" 
     End If 

Else 
     DoCmd.Hourglass False 
     MsgBox "ERROR: Unable to backup data file" 
End If 

DoCmd.Hourglass False 

Answer 9

Trate de añadir este módulo, bastante sencillo, basta con lanza de acceso, se abre la base de datos, establece la opción "Compactar al cerrar" a "Verdadero", luego se cierra.

Sintaxis para auto-compacta:

acCompactRepair "C:\Folder\Database.accdb", True 

Para volver a los valores predeterminados *:

acCompactRepair "C:\Folder\Database.accdb", False 

* No es necesario, pero si su base de datos back-end es> 1 GB esto puede ser bastante molesto cuando entra directamente y te tomará 2 minutos para dejarlo!

EDITAR: agregué la opción de recurse a través de todas las carpetas, la ejecuto cada noche para mantener las bases de datos al mínimo.

'accCompactRepair 
'v2.02 2013-11-28 17:25 

'=========================================================================== 
' HELP CONTACT 
'=========================================================================== 
' Code is provided without warranty and can be stolen and amended as required. 
' Tom Parish 
' TJP@tomparish.me.uk 
' http://baldywrittencod.blogspot.com/2013/10/vba-modules-access-compact-repair.html 
' DGF Help Contact: see BPMHelpContact module 
'========================================================================= 

'includes code from 
'http://www.ammara.com/access_image_faq/recursive_folder_search.html 
'tweaked slightly for improved error handling 

' v2.02 bugfix preventing Compact when bAutoCompact set to False 
'   bugfix with "OLE waiting for another application" msgbox 
'   added "MB" to start & end sizes of message box at end 
' v2.01 added size reduction to message box 
' v2.00 added recurse 
' v1.00 original version 

Option Explicit 

Function accSweepForDatabases(ByVal strFolder As String, Optional ByVal bIncludeSubfolders As Boolean = True _ 
    , Optional bAutoCompact As Boolean = False) As String 
'v2.02 2013-11-28 17:25 
'sweeps path for .accdb and .mdb files, compacts and repairs all that it finds 
'NB: leaves AutoCompact on Close as False unless specified, then leaves as True 

'syntax: 
' accSweepForDatabases "path", [False], [True] 

'code for ActiveX CommandButton on sheet module named "admin" with two named ranges "vPath" and "vRecurse": 
' accSweepForDatabases admin.Range("vPath"), admin.Range("vRecurse") [, admin.Range("vLeaveAutoCompact")] 

Application.DisplayAlerts = False 

Dim colFiles As New Collection, vFile As Variant, i As Integer, j As Integer, sFails As String, t As Single 
Dim SizeBefore As Long, SizeAfter As Long 
t = Timer 
RecursiveDir colFiles, strFolder, "*.accdb", True 'comment this out if you only have Access 2003 installed 
RecursiveDir colFiles, strFolder, "*.mdb", True 

    For Each vFile In colFiles 
     'Debug.Print vFile 
     SizeBefore = SizeBefore + (FileLen(vFile)/1048576) 
On Error GoTo CompactFailed 
    If InStr(vFile, "Geographical Configuration.accdb") > 0 Then MsgBox "yes" 
     acCompactRepair vFile, bAutoCompact 
     i = i + 1 'counts successes 
     GoTo NextCompact 
CompactFailed: 
On Error GoTo 0 
     j = j + 1 'counts failures 
     sFails = sFails & vFile & vbLf 'records failure 
NextCompact: 
On Error GoTo 0 
     SizeAfter = SizeAfter + (FileLen(vFile)/1048576) 

    Next vFile 

Application.DisplayAlerts = True 

'display message box, mark end of process 
    accSweepForDatabases = i & " databases compacted successfully, taking " & CInt(Timer - t) & " seconds, and reducing storage overheads by " & Int(SizeBefore - SizeAfter) & "MB" & vbLf & vbLf & "Size Before: " & Int(SizeBefore) & "MB" & vbLf & "Size After: " & Int(SizeAfter) & "MB" 
    If j > 0 Then accSweepForDatabases = accSweepForDatabases & vbLf & j & " failures:" & vbLf & vbLf & sFails 
    MsgBox accSweepForDatabases, vbInformation, "accSweepForDatabases" 

End Function 

Function acCompactRepair(ByVal pthfn As String, Optional doEnable As Boolean = True) As Boolean 
'v2.02 2013-11-28 16:22 
'if doEnable = True will compact and repair pthfn 
'if doEnable = False will then disable auto compact on pthfn 

On Error GoTo CompactFailed 

Dim A As Object 
Set A = CreateObject("Access.Application") 
With A 
    .OpenCurrentDatabase pthfn 
    .SetOption "Auto compact", True 
    .CloseCurrentDatabase 
    If doEnable = False Then 
     .OpenCurrentDatabase pthfn 
     .SetOption "Auto compact", doEnable 
    End If 
    .Quit 
End With 
Set A = Nothing 
acCompactRepair = True 
Exit Function 
CompactFailed: 
End Function 


'source: http://www.ammara.com/access_image_faq/recursive_folder_search.html 
'tweaked slightly for error handling 

Private Function RecursiveDir(colFiles As Collection, _ 
          strFolder As String, _ 
          strFileSpec As String, _ 
          bIncludeSubfolders As Boolean) 

    Dim strTemp As String 
    Dim colFolders As New Collection 
    Dim vFolderName As Variant 

    'Add files in strFolder matching strFileSpec to colFiles 
    strFolder = TrailingSlash(strFolder) 
On Error Resume Next 
    strTemp = "" 
    strTemp = Dir(strFolder & strFileSpec) 
On Error GoTo 0 
    Do While strTemp <> vbNullString 
     colFiles.Add strFolder & strTemp 
     strTemp = Dir 
    Loop 

    If bIncludeSubfolders Then 
     'Fill colFolders with list of subdirectories of strFolder 
On Error Resume Next 
     strTemp = "" 
     strTemp = Dir(strFolder, vbDirectory) 
On Error GoTo 0 
     Do While strTemp <> vbNullString 
      If (strTemp <> ".") And (strTemp <> "..") Then 
       If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then 
        colFolders.Add strTemp 
       End If 
      End If 
      strTemp = Dir 
     Loop 

     'Call RecursiveDir for each subfolder in colFolders 
     For Each vFolderName In colFolders 
      Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True) 
     Next vFolderName 
    End If 

End Function 

Private Function TrailingSlash(strFolder As String) As String 
    If Len(strFolder) > 0 Then 
     If Right(strFolder, 1) = "\" Then 
      TrailingSlash = strFolder 
     Else 
      TrailingSlash = strFolder & "\" 
     End If 
    End If 
End Function 

Answer 10

Application.SetOption "compacta Auto", False '(mencionado anteriormente) Utilice este botón con una leyenda: 'No DB Compactar al cerrar' código

escritura para alternar con el título "DB compacto En Cerrar " junto con Application.SetOption" Auto compact ", True

AutoCompact se puede establecer mediante el botón o por código, por ejemplo: después de importar tablas temporales grandes.

El formulario de inicio puede tener un código que apaga el Auto Compacto, para que no se ejecute cada vez.

De esta manera, no está tratando de luchar contra Access.

Answer 11

Si no desea utilizar compact close (por ejemplo, porque el front-end mdb es un programa de robot que se ejecuta continuamente), y no desea crear un mdb por separado solo para compactar, considere usar un archivo cmd.

dejo que mi robot.mdb comprobar su propio tamaño:

FileLen(CurrentDb.Name)) 

Si su tamaño es superior a 1 GB, se crea un archivo cmd como esto ...

Dim f As Integer 
Dim Folder As String 
Dim Access As String 
    'select Access in the correct PF directory (my robot.mdb runs in 32-bit MSAccess, on 32-bit and 64-bit machines) 
    If Dir("C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE") > "" Then 
     Access = """C:\Program Files (x86)\Microsoft Office\Office\MSACCESS.EXE""" 
    Else 
     Access = """C:\Program Files\Microsoft Office\Office\MSACCESS.EXE""" 
    End If 
    Folder = ExtractFileDir(CurrentDb.Name) 
    f = FreeFile 
    Open Folder & "comrep.cmd" For Output As f 
    'wait until robot.mdb closes (ldb file is gone), then compact robot.mdb 
    Print #f, ":checkldb1" 
    Print #f, "if exist " & Folder & "robot.ldb goto checkldb1" 
    Print #f, Access & " " & Folder & "robot.mdb /compact" 
    'wait until the robot mdb closes, then start it 
    Print #f, ":checkldb2" 
    Print #f, "if exist " & Folder & "robot.ldb goto checkldb2" 
    Print #f, Access & " " & Folder & "robot.mdb" 
    Close f 

... lanzamientos el archivo cmd ...

Shell ExtractFileDir(CurrentDb.Name) & "comrep.cmd" 

... y se apaga ...

DoCmd.Quit 

A continuación, el archivo cmd compacta y reinicia robot.mdb.

Answer 12

Pruebe esto. Funciona en la misma base de datos en la que reside el código. Simplemente llame a la función CompactDB() que se muestra a continuación. Asegúrese de que después de agregar la función, haga clic en el botón Guardar en la ventana del Editor de VBA antes de ejecutar por primera vez. Solo lo probé en Access 2010. Ba-da-bing, ba-da-boom.

Public Function CompactDB() 

    Dim strWindowTitle As String 

    On Error GoTo err_Handler 

    strWindowTitle = Application.Name & " - " & Left(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4) 
    strTempDir = Environ("Temp") 
    strScriptPath = strTempDir & "\compact.vbs" 
    strCmd = "wscript " & """" & strScriptPath & """" 

    Open strScriptPath For Output As #1 
    Print #1, "Set WshShell = WScript.CreateObject(""WScript.Shell"")" 
    Print #1, "WScript.Sleep 1000" 
    Print #1, "WshShell.AppActivate " & """" & strWindowTitle & """" 
    Print #1, "WScript.Sleep 500" 
    Print #1, "WshShell.SendKeys ""%yc""" 
    Close #1 

    Shell strCmd, vbHide 
    Exit Function 

    err_Handler: 
    MsgBox "Error " & Err.Number & ": " & Err.Description 
    Close #1 

End Function