Komprimering af Access database med VBA ??

Uddrag af eksisterende kode - til inspiration:

Sub Start()
Dim ts As String
    xsti = Tools.xsti
    testOmMappeFindes xsti + SikKopDB
   
    kilde1 = xsti + "db_løn.mdb"                    'p.t. database
    kilde2 = xsti + "ny_db_løn.mdb"                'arbejdskopi
   
    lukDB
   
    ts = Format(Now, "dd-mm-yy hhmmss")
    FileCopy kilde1, xsti + SikKopDB + "Kopi_" + ts + "_" + "DB_Løn.mdb" 'Skab en sikkerhedskopi
   
    ShowSize kilde1, "Før komprimering"
   
    If Dir(kilde2) <> "" Then _
      Kill kilde2                                  'slet arbejdsDB hvis eksisterer

Rem KOMPRIMERING:

    DBEngine.CompactDatabase kilde1, kilde2, , , ";pwd=" & Tools.xpw
   
    ShowSize kilde2, "Efter komprimering"
   
    Kill kilde1                                    'slet oprindelige db
    FileCopy kilde2, xsti + "DB_Løn.mdb"            'kopi ny til oprindeligt navn
    Kill kilde2                                    'slet arbejdsDB
End Sub

Eller bruge muligheden :

Options > General > Compact on close

' -----------------------------------------------------------------------------------
' This module is used to compress linked tables
' -----------------------------------------------------------------------------------
Option Compare Database                              'Use database string comparison
Option Explicit                                      'Variables MUST be declared

Public Function HENCompactData() As Integer
' -----------------------------------------------------------------------------------
' Purpose      : Calls rutines to compress linked tables
' Called from  :
' Returns      :
' Remarks      : Show user dialogbox
' -----------------------------------------------------------------------------------
  Dim bolTest As Boolean ', bolAppEnd As Boolean                'Testvariable
  Dim intX As Integer                                          'Counter
  Dim strMsg As String                                          'Usermessage
 
  bolTest = HENFormIsLoaded("frm-Oversigt")                    'Check if startup form is loaded
  If bolTest Then
    'bolAppEnd = True                                            'Ok to close
    DoCmd.Close acForm, "frm-Oversigt", acSaveNo              'Close form if loaded
  End If
   
          strMsg = "De har valgt at komprimere Deres data." & vbCrLf
  strMsg = strMsg + "Før det kan ske, skal De være sikker på," & vbCrLf
  strMsg = strMsg + "at ingen andre bruger Deres data," & vbCrLf
  strMsg = strMsg + "fordi dette vil forhindre Dem i at fuldføre opgaven." & vbCrLf & vbCrLf
  strMsg = strMsg + "Er De sikker på, at De vil fortsætte?"
 
  Beep                                                          'A sound
  intX = MsgBox(strMsg, vbCritical + vbYesNo + vbDefaultButton2, "Komprimér data")
  If intX <> 6 Then                                            'If the answer was no
'    Exit Function                                              'Stop here
  Else
    intX = HENCompactLinkedDB                                  'Compact tables
  End If

  If bolTest Then
    'bolAppEnd = False                                          'Not OK to end
    DoCmd.OpenForm "frm-Oversigt", acNormal, , , , acHidden    'Reopen form if loaded at start
  End If

End Function

Public Function HENCompactLinkedDB() As Integer
' -----------------------------------------------------------------------------------
' Purpose      : Compress linked tables
' Called from  :
' Returns      :
' Remarks      :
' -----------------------------------------------------------------------------------
On Error GoTo Error_HENCompactlinkedDB
  Const cTempDatabase As String = "~REPCPT~.MDB"              'Temp database to compact to
  Const cAccess As String = ";DATABASE="                      'Start of Connect property if Access table
  Dim avarDBs() As Variant                                    'Array with attached databases
  Dim avarUniqueDBs() As Variant                              'Unique array of databases
  Dim dbs As Database                                        'Current database
  Dim lngFoundlinked As Long                                  'Number of linked tables
  Dim lngDatabases As Long                                    'Number of linked databases
  Dim tdf As TableDef                                        'TableDef variable for loop
  Dim lngI As Long                                            'Counter variable for loop
  Dim strMsg As String                                        'Messagetext
 
  Set dbs = CurrentDb                                        'Use current database
  lngFoundlinked = 0                                          'Initialise variable
   
  For Each tdf In dbs.TableDefs                              'Loop tables in database
    If (tdf.Attributes And dbAttachedTable) And (Left(tdf.Connect, Len(cAccess)) = cAccess) Then
      lngFoundlinked = lngFoundlinked + 1                    'Found an linked table
      ReDim Preserve avarDBs(lngFoundlinked - 1)              'Make room for it
      avarDBs(lngFoundlinked - 1) = Mid(tdf.Connect, Len(cAccess) + 1, Len(tdf.Connect))
    End If
  Next
                                                              'Make a list of databasenames
  lngDatabases = HENUniqueArray(avarUniqueDBs, avarDBs, lngFoundlinked)
   
  For lngI = 0 To lngDatabases - 1                            'Loop all linked databases
    If (FileLen(avarUniqueDBs(lngI)) / 1024) < HENGetDiskFreeSpace(avarUniqueDBs(lngI)) Then
                                                              'Delete temp database
    If Dir(HENParsePathOrFile(avarUniqueDBs(lngI), True) & "\" & cTempDatabase) <> "" Then _
              Kill HENParsePathOrFile(avarUniqueDBs(lngI), True) & "\" & cTempDatabase
      Application.Echo True, "Komprimerer linket Database " & "'" & avarUniqueDBs(lngI) & "'"
      CompactDatabase avarUniqueDBs(lngI), HENParsePathOrFile(avarUniqueDBs(lngI), True) & "\" & cTempDatabase
      Kill avarUniqueDBs(lngI)
      Name HENParsePathOrFile(avarUniqueDBs(lngI), True) & "\" & cTempDatabase As avarUniqueDBs(lngI)
    Else
              strMsg = "Der er ikke diskplads nok til at komprimere databasen"
      strMsg = strMsg & avarUniqueDBs(lngI) + vbCrLf
      strMsg = strMsg & "Frigør diskplads på " & Left(avarUniqueDBs(lngI), 2)
      strMsg = strMsg & " og forsøg igen!"
      Beep                                                    'Make a sound
      MsgBox strMsg, vbCritical + vbOKOnly                    'Show message
    End If
  Next lngI 'Next datafile
  MsgBox "Data Komprimeret OK", vbInformation + vbOKOnly, "Opgave Udført"
   
Exit_HENCompactlinkedDB:
  Set dbs = Nothing                                          'Release object
  DoCmd.Hourglass False                                      'No waiting
  Application.Echo True
  Exit Function

Error_HENCompactlinkedDB:
  Select Case Err.Number
    Case conCantOpenExcl
              strMsg = "Komprimér/reparer Kunne ikke blive udført, fordi en anden anvender databasen." + vbCrLf
      strMsg = strMsg & "Sikr Dem at De er den eneste, der bruger den og prøv igen!"
      Beep                                                    'Make a sound
      MsgBox strMsg, vbCritical + vbOKOnly                    'Show message
    Case Else
      MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "Fejl i function 'HENCompactlinkedDB'"
  End Select
  Resume Exit_HENCompactlinkedDB
 
End Function

Private Function HENParsePathOrFile(ByVal strFullFile As String, ByVal boolReturnPath As Integer) As String
' -----------------------------------------------------------------------------------
' Purpose      : Returns path or filename (no path) from absolute filename
' Called from  :
' Returns      :
' Remarks      :
' -----------------------------------------------------------------------------------
On Error GoTo Error_HENParsePathOrFile
  Dim lngCurrentPos As Long                                              'Current position
  Dim lngLastPos As Long
 
  lngCurrentPos = InStr(strFullFile, "\")                                'Find first \
  Do Until lngCurrentPos = 0
    lngLastPos = lngCurrentPos
    lngCurrentPos = InStr(lngCurrentPos + 1, strFullFile, "\")            'Find last \
  Loop
  If boolReturnPath Then                                                  'If path
    HENParsePathOrFile = Trim(Left(strFullFile, lngLastPos - 1))
  Else                                                                    'Else filename
    HENParsePathOrFile = Trim(Right(strFullFile, Len(strFullFile) - lngLastPos))
  End If

Exit_HENParsePathOrFile:
  Exit Function

Error_HENParsePathOrFile:
  MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "Error in function 'HENParsePathOrFile'"
  Resume Exit_HENParsePathOrFile

End Function

Private Function HENUniqueArray(ByRef ravarReturnArray As Variant, ByRef ravarSourceArray As Variant, _
                                ByVal lngSourceElements As Long) As Long
' -----------------------------------------------------------------------------------
' Purpose      : Sorts values in array so each value only shows once
' Called from  :
' Returns      :
' Remarks      :
' -----------------------------------------------------------------------------------
On Error GoTo Error_HENUniqueArray
  Dim lngRetElements As Long                                            'Number of elements in array
  Dim lngI As Long                                                      'Counter
  Dim varCurrValue As Variant                                          'Current value
  Dim lngJ As Long                                                      'Counter
  Dim boolNoMatch As Integer                                            'Uniq value
 
  lngRetElements = 0                                                    'Initialise variable
  For lngI = 0 To lngSourceElements - 1                                'Loop all source-elements
    varCurrValue = ravarSourceArray(lngI)                              'Current value
    boolNoMatch = True                                                  'Uniq
    lngJ = 0                                                            'Initialise counter
    Do While boolNoMatch And lngJ <= lngRetElements - 1                'Check all elements
      If ravarReturnArray(lngJ) = varCurrValue Then boolNoMatch = False 'Not uniq
      lngJ = lngJ + 1
    Loop
    If boolNoMatch Then                                                'If uniq
      ReDim Preserve ravarReturnArray(lngRetElements)                  'Make room in array
      ravarReturnArray(lngRetElements) = varCurrValue                  'Put value
      lngRetElements = lngRetElements + 1                              'Add 1 to elements
    End If
  Next lngI                                                            'Next source-element
  HENUniqueArray = lngRetElements                                      'Returnvalue

Exit_HENUniqueArray:
  Exit Function

Error_HENUniqueArray:
  MsgBox Err.Number & ": " & Err.Description, vbOKOnly + vbCritical, "Error in function 'HENUniqueArray'"
  Resume Exit_HENUniqueArray

End Function

Hej Eksperter.

Mange tak for jeres vidt forskellige bidrag.
Nu har jeg fået løst mit "problem" og pointene går til:

Jensen363 ... for "hvorfor gå over åen efter vand", når løsninger ligger et flueben væk i Access :o)

Jensen363, sender du lige et svar ... så skal jeg returnere lidt point.

Go´ weekend,
Nicolai.

Husk nu, at det ikke gælder linkede databaser, men der kan man vel også sætte et flueben. Husk også, at det tager en ikke ubetydelig tid at komprimere en 60 mb database.

Smart løsning, men nu bad du jo udtrykkelig om en VBA løsning ;-)

Jeg deler gerne :-)

Kommentar :

Var en VBA-løsning påkrævet, havde jeg naturligvis givet den, men jeg vurderede ud fra sprøgsmålet, at det foreslåede var alt rigeligt i den forbindelse :-)

no worries

Hej Hnteknik

Når du siger det ikke virker ved linkede databaser ... mener du så en database, hvor tabellerne og selve applikationen er splittet op ?

Jeg har faktisk splittet databasen op og mit "problem" er, at hastigheden for load af diverse formularer + indhold ofte tager umiddelbart lang tid ? ... Tabellerne ligger på et fælles netværksdrev og selve applikationen (formularer, forespørgsler, moduler og rapporter ) ligger lokalt på 2 forskellige pc´ere.

Min første idé til løsning af "problemet" var at komprimere skidtet ??

Er jeg på rette spor eller har du/I andre gode forslag ??

Med venlig hilsen, Nicolai

Ja Compact on close vil kun virke på den database, der er åben.
Comprimering vil hjælpe, men store mængder data vil sløve det hele ned. Modsat SQL så skal Access sende det hele gennem nettet for at få det behandlet og kræver stor båndbredde. Prøv efter komprimering om du kan reducere datamængden i tabeller.

Gentagen komprimering af programdelen giver ikke noget.

Hej Hnteknink

Send et "svar" og jeg skal dele pointene mellem dig og Jensen363

Og endnu en gang, tusind tak for jeres input.

Mvh Nicolai

OK