Comprimeren Access Database (met wachtwoord)

[Radjesh Klauke]

Een tijdje geleden was ik weer eens bezig met gegevens toevoegen en verwijderen uit een AccessDatabase. Het vervelende was dat het bestand erg groot werd, terwijl er helemaal niet veel gegevens in stonden.

Deze code comprimeert een AccessDatabase. Alvorens hij dit doet wordt er een backup gemaakt met de datum in de bestandsnaam. Code naar eigen smaak inrichten.

Indien mensen het willen wil ik er wel een aparte tool voor maken.

Zet de reference naar: Micorsoft Jet and Replication Objects 2.x Library

Plaats de code in het formulier:

Code: Selecteer alles

Private Const Provider = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Private Const JetVersion = ";Jet OLEDB:Engine Type=5"

Private Sub Command1_Click()
On Error GoTo ErrBackupDB
    Dim fName As String
    fName = "Test.mdb"
   
    FileCopy App.Path & "\Test.mdb", App.Path & "\Backup\" & Format(Now, "mm-dd-yyyy") & " " & fName
    CompactDatabase App.Path & "\Test.mdb", ""
Exit Sub
ErrBackupDB:
    MsgBox Err.Description
End Sub

'    -----------------------------------------------------------------------------

Private Sub CompactDatabase(pstrDatabase As String, Optional pstrPassword As String)
    On Error GoTo CompactDatabaseErr
    Dim JRO As JetEngine
    Dim strPassword As String
    Dim strTemp As String

    ' Generate temporary file name
    strTemp = Left(pstrDatabase, InStrRev(pstrDatabase, "\")) & "Compact.mdb"
    If Len(Dir(strTemp)) <> 0 Then Kill strTemp

    ' Create password string
    If Len(pstrPassword) <> 0 Then strPassword = ";Jet OLEDB:Database Password=" & pstrPassword

    ' Compact database
    Set JRO = New JetEngine
        JRO.CompactDatabase Provider & pstrDatabase & strPassword, Provider & strTemp & JetVersion & strPassword
    Set JRO = Nothing

    Kill pstrDatabase                   ' Copy compacted version over old one
    Name strTemp As pstrDatabase

    MsgBox "Database compression and backup completed     ", vbInformation + vbOKOnly, "Database info"
CompactDatabaseExit:
    Exit Sub

CompactDatabaseErr:
    MsgBox Err.Description, vbInformation, "Notice"
    Resume CompactDatabaseExit
End Sub

[Radjesh Klauke]

Code: Selecteer alles

Option Explicit

'   Add a reference to Microsoft Access xx.0 Object Library

Sub CompactRepair()
    On Error GoTo MyError
    Dim oApp As Access.Application
    Set oApp = New Access.Application
        oApp.DBEngine.CompactDatabase App.Path & "\Test.mdb", App.Path & "\Test2.mdb"
        Kill App.Path & "\Test.mdb"
        Name App.Path & "\Test2.mdb" As App.Path & "\Test.mdb"
    MsgBox "Compressie gereed!  ", vbOKOnly + vbInformation, "Database Informatie"
    oApp.Quit acQuitSaveNone
    Set oApp = Nothing
    Exit Sub
MyError:
    MsgBox Err.Number & " - " & Err.Description, vbOKOnly
End Sub