Backup af database

http://www.mvps.org/access/api/api0026.htm

Hej terry
Jeg er sikker på at det virker ,men jeg er ikke så stærk i at skrive function,så hvis du vil hjælpe mig .vil jeg blive meget taknemlig.
function : skal copy en database C:\hgr_be.mdb og gemmene det copyet på
D:\gem\hg_be.mdb.
håber at du kan hjælpe mig
med venlig hilsen
jubas

If I get time this evening then I will see what I can do.

jubas>Is it the current database you want to copy or is it another?

NOTE: THis code copies the CURRENT dB to D:\gem\hg_be.mdb

You place this in the On click event for the button on the form

fMakeBackup

Then place this code in a new Module. You need a reference to DAO which you can find in the Tools+references menu.


'********** Code Start *************
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
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 = "Are you sure that you want to make a copy of the database?"
    If MsgBox(strMsg, vbQuestion + vbYesNo, "Please confirm") = vbNo Then _
            Err.Raise cERR_USER_CANCEL
           
    lngFlags = FOF_SIMPLEPROGRESS Or _
                            FOF_FILESONLY Or _
                            FOF_RENAMEONCOLLISION
    With tshFileOp
        .wFunc = FO_COPY
        .hwnd = hWndAccessApp
        .pFrom = CurrentDb.Name & vbNullChar
        .pTo = "D:\gem\hg_be.mdb" & vbNullCahr 'This is where the copy is to be placed
        .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
'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 DAO.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 ***************

jeg takker mange gange for venligheden

selv tak jubas