Ανανέωση ιστοσελίδας

[anestaki]

Καλησπέρα σε όλους
Το θέμα έχει επαναληφθεί πολλές φορές αλλά στην αναζήτηση μου δεν βρήκα κάτι που να κάνει ότι ζητώ με των παρακάτω κώδικα κανό Backup σε όλους τους συνδεδεμένους πίνακες. Θα με ενδιέφερε να κανό την υπάρχουσα βάση μόνο και φυσικά δημιουργώντας τον φάκελο Backup όπως ακριβώς λειτουργεί και ο παρακάτω κώδικας .
Όποια βοήθεια δεκτή σας ευχαριστώ εκ των προτέρων Γιώργος.

Option Compare Database
Option Explicit
'Temporary database name during backup
Private Const cTempDatabase = "~DataFile~.MDT"
'Database password if required
Private Const cstrPassword = ""
Private Function GetAppOption(strOption As String) As Variant
    'this function returns appliction options,
    'you can replace it with your function or
    'just read from hidden form with option values
    Select Case strOption
        Case "BackUpInterval"
            GetAppOption = 1 'Every day
        Case "BackupPath"
            GetAppOption = "" 'if empty - then using application path
        Case "LeaveCopies"
            GetAppOption = 3 ' we leave 3 last backups
        Case "CompactAfterBackUp"
            GetAppOption = True 'we will compact BE
    End Select
End Function

Public Function ToBackup() As Boolean
On Local Error GoTo ToBackup_Err
    Dim dbData As Database
    
    Dim datLastBackupDate As Date, intBackupInterval As Integer
    
    If Len(cstrPassword) > 0 Then
        Set dbData = DBEngine.OpenDatabase(WhereAttached(), False, False, ";pwd=" & cstrPassword)
    Else
        Set dbData = DBEngine.OpenDatabase(WhereAttached())
    End If
    
    datLastBackupDate = CDate(PrpGet(dbData, "LastBackUp"))
    dbData.Close

    intBackupInterval = GetAppOption("BackUpInterval")
    If intBackupInterval = 0 Then GoTo ToBackup_End
    
    If ((VBA.Date - datLastBackupDate) >= intBackupInterval) Then
        ToBackup = True
    End If

ToBackup_End:
    Exit Function
ToBackup_Err:
    Select Case Err.Number
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.description & ")"
            Resume ToBackup_End
    End Select
End Function
Public Function BackUpNow(Optional strFilename As String)
On Local Error GoTo BackUpNow_Err
    Dim strMDTSourcePath As String, strBackupPath As String, intLeaveCopies As _
        Integer
    Dim strBackupFile As String, i As Integer, strTemp As String
    Dim BackupArray() As String
    Dim dbData As Database
    DoCmd.Hourglass True
    Application.Echo True, "Backuping database..."
    MsgBox "ΤΟ BACKUP ΘΑ ΔΗΜΙΟΥΡΓΗΘΕΙ ΣΤΟ ΦΑΚΕΛΟ " & vbCrLf & _
        "BACKUP ΠΟΥ ΒΡΙΣΚΕΤΑΙ ΣΤΟΝ ΙΔΙΟ ΦΑΚΕΛΟ" & vbCrLf & "ΜΕ ΤΗΝ ΕΦΑΡΜΟΓΗ", _
        vbInformation
    If Len(strFilename) = 0 Then
        strMDTSourcePath = WhereAttached()
    Else
        strMDTSourcePath = strFilename
    End If
    strBackupPath = GetAppOption("BackupPath")
    intLeaveCopies = GetAppOption("LeaveCopies")
    
    If Len(strBackupPath) < 3 Then
        strBackupPath = CurrentProject.path & "\BackUp"
    End If
    If Len(Dir(strBackupPath & "\", vbDirectory)) = 0 Then
        MkDir strBackupPath
    End If
    strBackupFile = strBackupPath & "\Backup_" & Format(Now, "yymmdd_hhmmss") & _
        "_Of_" & Mid$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\") + 1)
    If Len(Dir(strBackupFile)) > 0 Then
        Kill strBackupFile
    End If
    FileCopy strMDTSourcePath, strBackupFile
    strTemp = Dir(strBackupPath & "\Backup_" & "??????_??????" & "_Of_" & _
        Mid$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\") + 1))
    Do While Len(strTemp) > 0
        ReDim Preserve BackupArray(1 To i + 1)
        BackupArray(i + 1) = strTemp
        strTemp = Dir
        i = i + 1
    Loop
    BubbleSort BackupArray()
    For i = 1 To UBound(BackupArray) - intLeaveCopies
        Kill strBackupPath & "\" & BackupArray(i)
    Next i
    If Len(cstrPassword) > 0 Then
        Set dbData = DBEngine.OpenDatabase(strMDTSourcePath, False, False, _
            ";pwd=" & cstrPassword)
    Else
        Set dbData = DBEngine.OpenDatabase(strMDTSourcePath)
    End If

    PrpSet dbData, "LastBackUp", dbDate, Date
    dbData.Close
    
    If GetAppOption("CompactAfterBackUp") Then
        Application.Echo True, "Coimpacting database..."
        strTemp = Left$(strMDTSourcePath, InStrRev(strMDTSourcePath, "\")) & _
            cTempDatabase
        If Len(Dir(strTemp)) > 0 Then Kill strTemp
        
        If Len(cstrPassword) > 0 Then
            CompactDatabase strMDTSourcePath, strTemp, ";pwd=" & cstrPassword, , _
                ";pwd=" & cstrPassword
        Else
            CompactDatabase strMDTSourcePath, strTemp
        End If
        Kill strMDTSourcePath
        Name strTemp As strMDTSourcePath
    End If
    
BackUpNow_End:
    DoCmd.Hourglass False
    Application.Echo True
    MsgBox "ΤΕΛΟΣ ΤΗΣ ΔΙΑΔΙΚΑΣΙΑΣ BACKUP", vbInformation
    Exit Function
BackUpNow_Err:
    Select Case Err.Number
        Case 70, 3356
            
            MsgBox "BACKUP ΑΔΥΝΑΤΟ - Η ΒΑΣΗ ΔΕΔΟΜΕΝΩΝ ΕΙΝΑΙ ΗΔΗ ΑΝΟΙΧΤΗ:" & _
                vbCrLf & "" '                    & strMDTSourcePath ' _
                & vbCrLf & _
                "Backing up is to be perfomed on the first user logging in." ' _
                & " Since you watch this message," '                    & vbCrLf & _
                "- either some workstation has not been configured to backup automatically," _
                '                    & vbCrLf & _
                "- or some workstation has an invalid system date/time setting.", _
                vbInformation
            Resume BackUpNow_End
        Case 68, 71, 76
            MsgBox "ΤΟ Backup ΑΠΕΤΥΧΕ!" & _
                "@Ο ΦΑΚΕΛΟΣ ΔΕΝ ΕΙΝΑΙ ΔΙΑΘΕΣΙΜΟΣ Η ΔΕΝ ΜΠΟΡΕΙ ΝΑ ΔΗΜΙΟΥΡΓΗΘΕΙ Η Ο ΔΙΣΚΟΣ ΔΕΝ ΕΙΝΑΙ ΕΤΟΙΜΟΣ.", _
                vbInformation
            Resume BackUpNow_End
        Case 3050
             Resume BackUpNow_End
        Case Else
            MsgBox "Error " & Err.Number & " (" & Err.description & ")"
            Resume BackUpNow_End
    End Select
End Function
Sub BubbleSort(pstrItem() As String)

    Dim intDone As Integer, intRow As Integer, intLastItem As Integer
    intLastItem = UBound(pstrItem)
    Do
        intDone = True
        For intRow = 1 To intLastItem - 1
            If pstrItem(intRow) > pstrItem(intRow + 1) Then
                SwapStr pstrItem(), intRow, intRow + 1
                intDone = False
            End If
        Next
    Loop Until intDone
End Sub
Sub SwapStr(pstrItem() As String, ByVal pintRow1 As Integer, ByVal pintRow2 As Integer)

    ' Swaps two elements of pstrItem()
    '
    ' Called from all sort routines except strInsertSort
    '
    Dim strTemp As String
    '
    strTemp = pstrItem(pintRow1)
    pstrItem(pintRow1) = pstrItem(pintRow2)
    pstrItem(pintRow2) = strTemp

End Sub
Public Function WhereAttached() As String
    
    Dim MyTable As TableDef
    Dim MyDB As Database
    Dim i As Integer
    Dim intPos1 As Integer, intPos2 As Integer
On Error GoTo Err_WhereAttached
    WhereAttached = ""
    Set MyDB = CurrentDb
        
    For i = 0 To MyDB.TableDefs.count - 1
        Set MyTable = MyDB.TableDefs(i)
        If MyTable.Connect <> "" Then
            intPos1 = InStr(1, MyTable.Connect, "DATABASE=")
            If intPos1 > 0 Then
                intPos2 = InStr(intPos1, MyTable.Connect, ";")
                If intPos2 > 0 Then
                    WhereAttached = VBA.Mid$(MyTable.Connect, intPos1 + 9, intPos2 - intPos1 - 9)
                Else
                    WhereAttached = VBA.Mid$(MyTable.Connect, intPos1 + 9)
                End If
            End If
            Exit For
        End If
    Next i

Exit_WhereAttached:
    Exit Function

Err_WhereAttached:
    MsgBox "Error " & Err.Number & " (" & Err.description & ")"
    Resume Exit_WhereAttached

End Function
Private Function PrpGet(dbs As Database, strPrpName As String) As Variant
On Local Error Resume Next
    PrpGet = dbs.Containers!Databases.Documents("UserDefined").Properties(strPrpName).Value
End Function
Public Function PrpSet(dbs As Database, strPropName As String, intPropType _
    As Integer, varGen As Variant) As Boolean
    
    Dim doc As Document, prp As Property, cnt As Container

    Const conPropertyNotFound = 3270    ' Property not found error.
    Set cnt = dbs.Containers!Databases  ' Define Container object.

On Local Error GoTo PrpSet_Err
    
    Set doc = cnt.Documents!UserDefined
    doc.Properties.Refresh
    ' Set custom property name. If error occurs here it means
    ' property doesn't exist and needs to be created and appended
    ' to Properties collection of Document object.
    Set prp = doc.Properties(strPropName)
    prp = varGen
    PrpSet = True
PrpSet_Bye:
    Exit Function

PrpSet_Err:
    If Err = conPropertyNotFound Then
        Set prp = doc.CreateProperty(strPropName, intPropType, varGen)
        doc.Properties.Append prp       ' Append to collection.
        Resume Next
    ElseIf Err.Number = 3265 Then
        Resume PrpSet_Bye
    Else ' Unknown error.
        PrpSet = False
        Resume PrpSet_Bye
    End If
End Function