عمل نسخة إحتياطية أرجو المساعدة

[fefo]

السلام عليكم سلام إلى جميع أعضاء المنتدى

أرجوك لمن يستطيع أن يساعدني كتابة الكود من أجل النسخ الأحتياطي لقاعدة البيانات وإمكانية تحديد مكان حفظ النسخة الأحتياطية جازكم الله كل خير والسلام عليكم

[التقني]

جرب هذا الكود ( لم أجربه شخصيا)

وهو من اعداد الأخ أشرف خليل جزاه الله كل خير

Private Type SHFILEOPSTRUCT 
      hWnd As Long 
      wFunc As Long 
      pFrom As String 
      pTo As String 
      fFlags As Integer 
      fAnyOperationsAborted As Boolean 
      hNameMappings As Long 
      lpszProgressTitle As String 
      End Type 

      Private Const FO_MOVE As Long = &H1 
      Private Const FO_COPY As Long = &H2 
      Private Const FO_DELETE As Long = &H3 
      Private Const FO_RENAME As Long = &H4 

      Private Const FOF_MULTIDESTFILES As Long = &H1 
      Private Const FOF_CONFIRMMOUSE As Long = &H2 
      Private Const FOF_SILENT As Long = &H4 
      Private Const FOF_RENAMEONCOLLISION As Long = &H8 
      Private Const FOF_NOCONFIRMATION As Long = &H10 
      Private Const FOF_WANTMAPPINGHANDLE As Long = &H20 
      Private Const FOF_CREATEPROGRESSDLG As Long = &H0 
      Private Const FOF_ALLOWUNDO As Long = &H40 
      Private Const FOF_FILESONLY As Long = &H80 
      Private Const FOF_SIMPLEPROGRESS As Long = &H100 
      Private Const FOF_NOCONFIRMMKDIR As Long = &H200 

      Private Declare Function apiSHFileOperation Lib "Shell32.dll" _ 
      Alias "SHFileOperationA" _ 
      (lpFileOp As SHFILEOPSTRUCT) _ 
      As Long 

      Function fMakeBackup() As Boolean 
      Dim strMsg As String 
      Dim tshFileOp As SHFILEOPSTRUCT 
      Dim lngRet As Long 
      Dim strSaveFile As String 
      Dim lngFlags As Long 
      Const cERR_USER_CANCEL = vbObjectError + 1 
      Const cERR_DB_EXCLUSIVE = vbObjectError + 2 
      On Local Error GoTo fMakeBackup_Err 

      If fDBExclusive = True Then Err.Raise cERR_DB_EXCLUSIVE 

      strMsg = "هل أنت متأكد من أنك تريد عمل نسخة لهذه القاعدة ?" 
      If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo Then _ 
      Err.Raise cERR_USER_CANCEL 

      lngFlags = FOF_SIMPLEPROGRESS Or _ 
      FOF_FILESONLY Or _ 
      FOF_RENAMEONCOLLISION 
      strSaveFile = CurrentDb.Name 
      With tshFileOp 
      .wFunc = FO_COPY 
      .hWnd = hWndAccessApp 
      .pFrom = CurrentDb.Name & vbNullChar 
      .pTo = strSaveFile & vbNullChar 
      .fFlags = lngFlags 
      End With 
      lngRet = apiSHFileOperation(tshFileOp) 
      fMakeBackup = (lngRet = 0) 

      fMakeBackup_End: 
      Exit Function 
      fMakeBackup_Err: 
      fMakeBackup = False 
      Select Case Err.Number 
      Case cERR_USER_CANCEL: 
      'do nothing 
      Case cERR_DB_EXCLUSIVE: 
      MsgBox "The current database " & vbCrLf & CurrentDb.Name & vbCrLf & _ 
      vbCrLf & "is opened exclusively. Please reopen in shared mode" & _ 
      " and try again.", vbCritical + vbOKOnly, "Database copy failed" 
      Case Else: 
      strMsg = "Error Information..." & vbCrLf & vbCrLf 
      strMsg = strMsg & "Function: fMakeBackup" & vbCrLf 
      strMsg = strMsg & "Description: " & Err.Description & vbCrLf 
      strMsg = strMsg & "Error #: " & Format$(Err.Number) & vbCrLf 
      MsgBox strMsg, vbInformation, "fMakeBackup" 
      End Select 
      Resume fMakeBackup_End 
      End Function 

      Private Function fCurrentDBDir() As String 

      Dim strDBPath As String 
      Dim strDBFile As String 
      strDBPath = CurrentDb.Name 
      strDBFile = Dir(strDBPath) 
      fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1) 
      End Function 

      Function fDBExclusive() As Integer 
      Dim db As Database 
      Dim hFile As Integer 
      hFile = FreeFile 
      Set db = CurrentDb 
      On Error Resume Next 
      Open db.Name For Binary Access Read Write Shared As hFile 
      Select Case Err 
      Case 0 
      fDBExclusive = False 
      Case 70 
      fDBExclusive = True 
      Case Else 
      fDBExclusive = Err 
      End Select 
      Close hFile 
      On Error GoTo 0 
      End Function

وبالتوفيق

[التقني]

وهذا المثال للأخوين :

طارق حنيدق

و

محمد طاهر

جزاهما الله كل خير

3in1.rar