title image


Smiley Hier eine Sub, um DB aus Excel zu komprimieren
Hier eine Sub, die in meiner Mappe im Blatt 'Einstellungen' alle Dateien mit der Endung *.mdb sucht und Access aus Excel anweist, diese zu komprimieren. Du musst natürlich, der Automation sei dank einen Verweis auf die Microsoft Access Libary in VBA einfügen. Bei Fragen einfach nochmal schreiben.



Public Sub Komprimiere_DatenBanken()

Dim Access_Objekt As Access.Application

Dim DatenBanken() As String

Dim y As Byte

Dim Anzahl As Byte

On Error GoTo Sub_Fehler

Application.ScreenUpdating = False

Application.DisplayAlerts = False

y = 6

Anzahl = 0

ReDim DatenBanken(0)

While Workbooks(XXXX).Sheets("Einstellungen").Cells(y, 1).Value ""

If Strings.LCase(Strings.Right(Workbooks(Gib_Wert_aus_Einstellungen_zurueck("Eigener ProgrammName")).Sheets("Einstellungen").Cells(y, 2).Value, 4)) = ".mdb" Then

Anzahl = Anzahl + 1

ReDim Preserve DatenBanken(Anzahl)

DatenBanken(Anzahl) = Workbooks(Gib_Wert_aus_Einstellungen_zurueck("Eigener ProgrammName")).Sheets("Einstellungen").Cells(y, 2).Value

End If

y = y + 1

Wend

If Anzahl > 0 Then

Set Access_Objekt = New Access.Application 'Ein leeres Access öffnen

For y = 1 To Anzahl

'Prüfen ob es schon eine temp datenbank gibt, wenn ja:löschen

If Dir(Strings.Left(DatenBanken(y), Len(DatenBanken(y)) - 4) & "_komprimiert.mdb") "" Then FileSystem.Kill Strings.Left(DatenBanken(y), Len(DatenBanken(y)) - 4) & "_komprimiert.mdb"

'DatenBank komprimieren und unter ...._komprimiert.mdb abspeichern

Application.StatusBar = "Komprimiere " & DatenBanken(y) & " ..."

DBEngine.CompactDatabase DatenBanken(y), Strings.Left(DatenBanken(y), Len(DatenBanken(y)) - 4) & "_komprimiert.mdb", , , ";pwd=" & strDatenBankPassWort

'Die Originale Datenbank löschen

If Err.Number = 0 Then

FileSystem.Kill DatenBanken(y)

Else

Fehlerfenster "Achtung, bei der Komprimierung der DatenBank " & DatenBanken(y) & " gab es einen Fehler!" & Strings.Chr(13) & _

"Die Datenbank wurde nicht komprimiert!", "KomprimierungsFehler", "Access"

End If

'Die Neue Datenbank in den Namen der ersten Umbenennen

FileSystem.FileCopy Strings.Left(DatenBanken(y), Len(DatenBanken(y)) - 4) & "_komprimiert.mdb", DatenBanken(y)

'Die Temporäre Datenbank löschen

FileSystem.Kill Strings.Left(DatenBanken(y), Len(DatenBanken(y)) - 4) & "_komprimiert.mdb"

Next

End If



Sub_Ende: 'Sprungmarke Ende

Application.StatusBar = False

Application.DisplayAlerts = True

Application.ScreenUpdating = True

On Error Resume Next

Access_Objekt.CloseCurrentDatabase

Access_Objekt.Quit

Set Access_Objekt = Nothing

Exit Sub



Sub_Fehler: 'FehlerSprungmarke

Fehlerfenster "Es ist folgender Fehler aufgetreten: " & Err.Description, _

"Fehler in Sub Komprimiere_DatenBanken", "Excel"

GoTo Sub_Ende

End Sub



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: