تعديل على كود النسخ الاحتياطي _ تصفية وحذف النسخ المتراكمة القديمة والمكررة

[محمد التميمي]

السلام عليكم.

اخواني الافاضل لدي في الملف المرفق نموذج يحتوي على زر للنسخ الاحتياطي ويعمل بشكل مثالي.... حيث يجمع قواعد البانات من النسخ الاحتياطي في فولدر جانبي باسم (Backup)... باسم تاريخ اليوم والشهر والسنة

حيث لو ضغطنا على زر النسخ الاحتياطي كل يوم يولد لنا ثلاثين قاعدة على عدد ايام الشهر..

المطلوب اخواني الكرام :-

تعديل على كود النسخ الاحتياطي ان يقوم الكود بالاحتفاظ بقاعدتين اثنين فقط ويمسح المستنسخ بتاريخ قديم

 

مع فائق الشكر والاحترام........

New.rar

[ابوخليل]

تفضل تجد مطلوبك هنا

[Foksh]

ومشاركة مع والدنا الحبيب @ابوخليل ، 

جرب هذا التعديل مع إمكانية تغيير عدد النسخ التي تريدها ان تبقى ، في الكود التالي :-

 

Private Sub Comannd184_Click()
    Dim MyFile As String
    Dim DstFile As String
    Dim BackupDir As String
    Dim Syso As Object
    Dim File As Object
    Dim BackupFiles As Collection
    Dim i As Long
    On Error GoTo ErrH
    MyFile = CurrentProject.FullName
    BackupDir = CurrentProject.Path & "\Backup\"
    DstFile = BackupDir & "Database - " & Format(Date, "yyyy - mm - dd") & ".accde"
    Set Syso = CreateObject("Scripting.FileSystemObject")
    Syso.CopyFile MyFile, DstFile
    Set BackupFiles = New Collection
    For Each File In Syso.GetFolder(BackupDir).Files
        If InStr(File.Name, "Database - ") > 0 Then
            BackupFiles.Add File
        End If
    Next File
    If BackupFiles.Count > 2 Then
        For i = 1 To BackupFiles.Count - 2
            Kill BackupFiles(i).Path
        Next i
    End If
    Name DstFile As DstFile & ".ptc"
    DBEngine.CompactDatabase DstFile & ".ptc", DstFile
    Kill DstFile & ".ptc"
MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "yyyy-mm-dd") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد"
Exit Sub
ErrH:
    MsgBox "خطأ: " & Err.Description, vbCritical
End Sub

 

ملفك بعد التعديل 

New.zip

[محمد التميمي]

منذ ساعه, ابوخليل said:

تفضل تجد مطلوبك هنا

شكرا جزيلا اخي واستاذي ابو خليل المحترم..........

19 دقائق مضت, Foksh said:

ومشاركة مع والدنا الحبيب @ابوخليل ، 

جرب هذا التعديل مع إمكانية تغيير عدد النسخ التي تريدها ان تبقى ، في الكود التالي :-

 

Private Sub Comannd184_Click()
    Dim MyFile As String
    Dim DstFile As String
    Dim BackupDir As String
    Dim Syso As Object
    Dim File As Object
    Dim BackupFiles As Collection
    Dim i As Long
    On Error GoTo ErrH
    MyFile = CurrentProject.FullName
    BackupDir = CurrentProject.Path & "\Backup\"
    DstFile = BackupDir & "Database - " & Format(Date, "yyyy - mm - dd") & ".accde"
    Set Syso = CreateObject("Scripting.FileSystemObject")
    Syso.CopyFile MyFile, DstFile
    Set BackupFiles = New Collection
    For Each File In Syso.GetFolder(BackupDir).Files
        If InStr(File.Name, "Database - ") > 0 Then
            BackupFiles.Add File
        End If
    Next File
    If BackupFiles.Count > 2 Then
        For i = 1 To BackupFiles.Count - 2
            Kill BackupFiles(i).Path
        Next i
    End If
    Name DstFile As DstFile & ".ptc"
    DBEngine.CompactDatabase DstFile & ".ptc", DstFile
    Kill DstFile & ".ptc"
MsgBox "تم انشاء قاعدة البيانات بنجاح" & vbNewLine & "Database successfully created" & vbNewLine & vbNewLine & "" & "اسم قاعدة البيانات" & vbNewLine & "The name of the database" & vbNewLine & "" & vbNewLine & "Backup-" & Format(Date, "yyyy-mm-dd") & vbNewLine & vbNewLine & "" & "مسار القاعدة الجديدة" & vbNewLine & "Path of the new rule" & vbNewLine & "" & vbNewLine & DstFile, vbMsgBoxRight + vbOKOnly, "emphasis" & "/" & "تاكيد"
Exit Sub
ErrH:
    MsgBox "خطأ: " & Err.Description, vbCritical
End Sub

 

ملفك بعد التعديل 

New.zip 166.06 kB · 0 downloads

بارك الله بك اخي واستاذي Foksh . التعديل يعمل بامتياز