Accès MS: comment compacter la base de données actuelle en VBA

essayez d'ajouter ce module, assez simple, lance simplement Access, ouvre la base de données, place l'option "Compact on Close" à "True", puis démissionne.

syntaxe to auto-compact:

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

Pour retourner à la valeur par défaut*:

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

*pas nécessaire, mais si votre base est >1 GO ce qui peut être assez ennuyeux lorsque vous allez directement et il faut 2 minutes pour quitter!

EDIT: ajouté l'option pour revenir à travers tous les dossiers, Je exécute cette nuit à réduire les bases de données au minimum.

'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

Oui c'est simple à faire.

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

fondamentalement, il trouve juste le menuitem "Compact et de réparation" et le clique, programmatiquement.

lorsque l'utilisateur quitte L'EF, tenter de renommer le BMD d'arrière-plan de préférence avec la date du jour dans le format AAAA-mm-JJ. Assurez-vous de fermer tous les formulaires reliés, y compris les formulaires cachés, et les rapports avant de le faire. Si vous recevez un message d'erreur, Oups, c'est occupé alors ne vous embêtez pas. Si elle est réussie, puis compacter en arrière.

Voir mon Backup, faites-vous confiance aux utilisateurs ou aux administrateurs système? conseils page pour plus d'information.

Si vous avez la base de données avec une extrémité avant et une extrémité arrière. Vous pouvez utiliser le code suivant sur le formulaire principal de votre formulaire principal de navigation:

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

Essayez ceci. Il fonctionne sur la même base de données que le code. Il suffit d'appeler la fonction CompactDB() ci-dessous. Assurez-vous qu'après avoir ajouté la fonction, vous cliquez sur le bouton Enregistrer dans la fenêtre de L'éditeur VBA avant de lancer pour la première fois. Je ne l'ai testé que dans 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

pour Access 2013, vous pouvez simplement faire

Sendkeys "%fic"

c'est la même chose que de taper ALT, F, I, C sur votre clavier.

il s'agit probablement d'une séquence différente de lettres pour différentes versions, mais le symbole "%" signifie "ALT", alors gardez-le dans le code. vous pouvez juste avoir besoin de changer les lettres, en fonction de ce que les lettres apparaissent lorsque vous appuyez sur ALT

lettres qui apparaissent en appuyant sur ALT dans accès 2013

je l'ai fait il y a plusieurs années sur 2003 ou peut-être 97, aïe!

Si je me souviens vous devez utiliser l'un des sous-commandes ci-dessus lié à une minuterie. vous ne pouvez pas opérer sur le db avec des connexions ou des formulaires ouverts.

donc vous faites quelque chose pour fermer tous les formulaires, et le coup d'envoi de la minuterie comme la dernière méthode de course. (qui appellera à son tour l'opération compacte une fois que tout ferme)

si vous n'avez pas compris cela je pourrais creuser à travers mon les archives et les tirer vers le haut.

DBEngine.CompactDatabase source, dest

Application.SetOption" auto compact", False '(mentionné ci-dessus)) Utilisez ceci avec une légende de bouton: "DB Not Compact On Close"

écrire le code pour basculer la légende avec " DB Compact on Close" avec l'Application.SetOption "Auto compact", True

AutoCompact peut être réglé à l'aide du bouton ou par code, ex: après importation de grandes tables temp.

le formulaire de démarrage peut avoir un code qui éteint Auto Compact, de sorte qu'il ne fonctionne pas chaque temps.

de cette façon, vous n'essayez pas de combattre L'accès.

si vous ne souhaitez pas utiliser compact on close (par exemple, parce que le mdb frontal est un programme de robot qui tourne continuellement), et que vous ne voulez pas créer un mdb séparé juste pour le compactage, envisagez d'utiliser un fichier cmd.

j'ai laissé mon robot.mdb vérifier sa propre taille:

FileLen(CurrentDb.Name))

Si sa taille dépasse 1 GO, il crée un fichier cmd comme ça ...

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

... lance le fichier cmd ...

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

... et s'arrête ...

DoCmd.Quit

Ensuite, le fichier cmd compacte et redémarre robot.BMD.

découvrez cette solution VBA Compact Current Database.

fondamentalement, il est dit que cela devrait fonctionner

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

il y a aussi celui de Michael Kaplan!--1-->BIENTÔT ("pas de Fermer, Ouvrir de Nouveaux"). Il faudrait l'enchaîner, mais c'est une façon de le faire.

Je ne peux pas dire que j'ai eu beaucoup de raisons de vouloir faire ça programmatiquement, puisque je programmais pour les utilisateurs finaux, et ils n'utilisent jamais rien d'autre que le devant dans l'interface utilisateur D'accès, et il n'y a aucune raison de compacter régulièrement un devant correctement conçu.