'<META name="Description" content="Add In 'Datensicherung C' für Access XP">
'DEKLARATION

Option Compare Database
Option Explicit


'1.F U N K T I O N

Function strt()
Dim antw%
antw = MsgBox("Soll die Datenbank auf Laufwerk C: gesichert werden ?", vbYesNo + vbQuestion, "DATENSICHERUNG")
If antw = vbYes Then
DoCmd.Minimize
datensicherungC
Else
DoCmd.Quit acQuitSaveAll
Exit Function
End If
DoCmd.Quit
End Function

'2.F U N K T I O N

Function datensicherungC()
Dim verz$
Dim antw%
Dim dbName As String, dbNameKurz As String
Dim fs As New FileSystemObject
Dim fehlerNr As Integer
Const VerzSich = "C:\DB\SICHERUNG\"
alleSchließen
fehlerNr = 0
On Error GoTo fehler
Application.Echo True, "Die Datenbank wird gesichert..."
dbName = Application.CurrentDb.Name
dbNameKurz = fs.GetFileName(dbName)
If DoesFileExist("C:\DB\SICHERUNG\", True) = False Then
MkDir "c:\DB\SICHERUNG"
End If
verz = CStr(Month(Date)) & "_" & CStr(Year(Date))
If DoesFileExist(VerzSich & verz, True) = False Then
MkDir VerzSich & verz
End If
If DoesFileExist(VerzSich & verz & "\" & dbNameKurz, False) = True Then
antw = MsgBox("Soll die vorhandene Datei überschrieben werden ?", vbQuestion + vbYesNo, "Datei ersetzen ?")
If antw = vbYes Then
Kill VerzSich & verz & "\" & dbNameKurz
Else
MsgBox "Datensicherung wurde abgebrochen !", vbInformation, "Vorgang beendet !"
Exit Function
End If
End If
fs.copyfile dbName, VerzSich & verz & "\X_" & dbNameKurz, True
Application.DBEngine.CompactDatabase VerzSich & verz & "\X_" & dbNameKurz, VerzSich & verz & "\" & dbNameKurz
fs.DeleteFile VerzSich & verz & "\X_" & dbNameKurz, True
Application.Echo True, ""
Exit Function
fehler:
fehlerNr = fehlerNr + 1
If Err.Number = 75 Then
Resume Next
ElseIf fehlerNr <= 5 Then
Resume
ElseIf fehlerNr> 5 Then
MsgBox Err.Number & " -> " & Err.Description
End If
End Function

'3. F U N K T I O N = Sub Prozedur

Sub alleSchließen()
Dim rs As Recordset
Dim frm As Form
For Each rs In CurrentDb.Recordsets
rs.Close
Next rs
End Sub

'4.F U N K T I O N

Function DoesFileExist(ByVal strFileName As String, Optional ByVal bolDirectory As Boolean) As Boolean
   
  On Error GoTo DoesFileExist_Error
   
  If Nz(strFileName, "") = "" Then Exit Function
 
  If bolDirectory = True Then
 
    If Len(Dir(strFileName, vbDirectory)) <> 0 And _
      Len(Dir(strFileName)) = 0 Then
      
      DoesFileExist = True
      
    End If
    
  Else
 
    If Len(Dir(strFileName)) <> 0 Then
      DoesFileExist = True
    End If
    
  End If
 
DoesFileExist_Error:
 
End Function