Komprimera databaser


Här demonstreras en teknik för att komprimera Access-databaser, vilket är nödvändigt att göra med jämna mellanrum.

I exemplet används s k Early Binding varför referenser måste anges till följande externa bibliotek:

1. Microsoft Scripting Runtime

2. Microsoft Jet and Replication Objects 2.5 Library eller senare.


I strängen för anslutningen till den nya databasen används Type=5, vilket refererar till version 2000 och senare. För version 97 används Type=4.


 Om ett felmeddelande erhålls vid kopiering till VBA-modul så läs mer här»
 

 

(© 2002 - 2005 All rights Colo - Used by permission)

Option Explicit

 

Sub Komprimera_Databas()

  '© 2005 Alla rättigheter XL-Dennis

  Dim JRO As JRO.JetEngine

  Dim fso As Scripting.FileSystemObject

  Dim stDBSource As String, stDBNew As String, stPath As String

  Dim stPathBackup As String

 

  On Error GoTo Error_Handling

 

  Set fso = New Scripting.FileSystemObject

  Set JRO = New JRO.JetEngine

 

  With ThisWorkbook

    stPath = .Path

    stPathBackup = .Path & "\Compress"

  End With

 

  'Skapa den temporära foldern.

  If Not fso.FolderExists(stPathBackup) Then

    MkDir stPathBackup

  End If

 

  'Anslutning till den aktuella databasen.

  stDBSource = "Provider=Microsoft.Jet.OLEDB.4.0;" & _

      "Data Source=" & stPath & "\xl.mdb;" & _

      "Jet OLEDB:Database Password=Dennis;"

 

  'Anslutning till den nya databasen.

  stDBNew = "Provider=Microsoft.Jet.OLEDB.4.0;" & _

      "Data Source=" & stPathBackup & "\xl.mdb;" & _

      "Jet OLEDB:Engine Type=5;" & _

      "Jet OLEDB:Database Password=Dennis;"

 

  'Komprimera databasen.

  JRO.CompactDatabase stDBSource, stDBNew

 

  'Kopiera den nya databasen.

  fso.CopyFile stPathBackup & "\xl.mdb", stPath & "\", OverWriteFiles:=True

 

  'Ta bort den temporära foldern.

  fso.DeleteFolder (stPathBackup)

 

  MsgBox "Databasen har framgångsrikt komprimerats!", vbInformation, _
              "Komprimera databasen"

 

ExitSub:

  'Frigör objekt från minnet.

  Set fso = Nothing

  Set JRO = Nothing

  Exit Sub

 

Error_Handling:

  MsgBox "Följande fel har inträffat :" & vbCrLf & _

               "Fel : " & Err.Description & " " & Err.Number & " " & Err.Source, vbCritical,  _

               "Komprimera registret"

  Resume ExitSub

End Sub