النسخ الاحتياطي لقاعدة البيانات

[احمد احمد احمد 000]

السلام عليكم ورحمة الله وبركاته 

تحية طيبة ...

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

المطلوب / تعديل الكود بحيث يمكنني اختار مكان الحفظ في كل مرة .

مع جزيل الشكر والتقدير ...

الكود.docx

تم تعديل فبراير 20, 2022 بواسطه احمد احمد احمد 000

[Moosak]

تفضل أخي أحمد أحمد أحمد 🙂

ضع هذا الكود في موديول :

Public Sub TakeBackup()

On Error GoTo MyErr

Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String

OldFile = CurrentProject.FullName

BackupFolder = SelectFolder

DBName = Left(CurrentProject.Name, InStrRev(CurrentProject.Name, ".") - 1)

NewFile = BackupFolder & "\" & DBName & "-Backup-" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-ss-AMPM.") & Right(OldFile, 5)
CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """"
Shell CopyMyDB, 0


MsgBox "Backup........Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " "

MyErr:
If Err.Number <> 0 Then
MsgBox Err.Number & " - " & Err.Description
End If

End Sub

Public Function SelectFolder()

On Error GoTo ErrorHandler

Dim FileDialog  As Object
Dim sPath       As String
Dim sFile       As String
  

  Set FileDialog = Access.Application.FileDialog(4)
    With FileDialog
      .AllowMultiSelect = False
      .Filters.Clear
      .Show
      .Title = "Please select folder"
      SelectFolder = .SelectedItems(1)
    End With

ExitHandler:
   Exit Function
ErrorHandler:
    Select Case Err.Number
        Case Is = 5
            MsgBox ChrW("1604") & ChrW("1602") & ChrW("1583") & ChrW("32") & ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1594") & ChrW("1575") & ChrW("1569") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1605") & ChrW("1585") & ChrW("32") & ChrW("46") & ChrW("46") & ChrW("46") & ChrW("32") & ChrW("40") & ChrW("32") & ChrW("1604") & ChrW("1605") & ChrW("32") & ChrW("1578") & ChrW("1602") & ChrW("1605") & ChrW("32") & ChrW("1576") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1610") & ChrW("1583") & ChrW("32") & ChrW("1571") & ChrW("1609") & ChrW("32") & ChrW("1605") & ChrW("1587") & ChrW("1575") & ChrW("1585") & ChrW("41") _
            , vbMsgBoxRight + vbMsgBoxRtlReading, _
             ChrW("1578") & ChrW("1606") & ChrW("1576") & ChrW("1610") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("40") & ChrW("32") & ChrW("65") & ChrW("116") & ChrW("116") & ChrW("101") & ChrW("110") & ChrW("116") & ChrW("105") & ChrW("111") & ChrW("110") & ChrW("32") & ChrW("41") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1600") & ChrW("1607")
        Case Else
            MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description
            Resume ExitHandler
    End Select

End Function

 

 

ثم قم باستدعائه هكذا :

Call TakeBackup()