--- Soumis par Dev Ashish---
Copier une base de données.
Trouvez ici une méthode, basée sur l'API, pour faire une copie de sayvegarde (backup) pour la base de donnée courante. Cette méthode ne fonctionne pas pour une base de données ouverte en mode exclusif.
La copie de sauvegarde est crée avec le préfixe "Copy of (?)", suivi du nom de la base de donnée elle-même, et ce, dans le même répertoire.
'********** Code Start ************* 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 = "Êtes-vous certain de vouloir générer une copie de cette base de données?" 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: 'ne rien faire 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 'code courtesy of 'Terry Kreft 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 '************* Code End ***************