Saltar al contenido

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

Solución:

Si desea compactar / reparar un archivo mdb externo (no en el que está trabajando en este momento):

Application.compactRepair sourecFile, destinationFile

Si desea compactar la base de datos con la 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 unas pocas líneas de código en un archivo “compactador” MDB adicional al que puede llamar cuando desee compactar / reparar un archivo mdb es muy útil: en la mayoría de las situaciones, el archivo que debe compactarse ya no se puede abrir normalmente. , por lo que debe llamar al método desde fuera del archivo.

De lo contrario, el autocompacto se establecerá de forma 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.

Para Access 2013, podría hacer

Sendkeys "%fic"

Esto es lo mismo que escribir ALT, F, I, C en su teclado.

Probablemente sea una secuencia de letras diferente para diferentes versiones, pero el símbolo “%” significa “ALT”, así que mantén eso en el código. es posible que solo necesite cambiar las letras, dependiendo de las letras que aparezcan cuando presione ALT

Letras que aparecen al presionar ALT en Access 2013

Intente agregar este módulo, bastante simple, simplemente inicia Access, abre la base de datos, establece la opción “Compactar al cerrar” en “Verdadero”, luego se cierra.

Sintaxis para autocompactar:

acCompactRepair "C:FolderDatabase.accdb", True

Para volver a los valores predeterminados *:

acCompactRepair "C:FolderDatabase.accdb", False

* no es necesario, pero si su base de datos de back-end es> 1GB, esto puede ser bastante molesto cuando ingresa directamente y toma 2 minutos para salir.

EDITAR: opción agregada para recurrir a todas las carpetas, ejecuto esto todas las noches 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
'   [email protected]
'   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
¡Haz clic para puntuar esta entrada!
(Votos: 0 Promedio: 0)



Utiliza Nuestro Buscador

Deja una respuesta

Tu dirección de correo electrónico no será publicada. Los campos obligatorios están marcados con *