如何复制当前打开的access数据库?

来源:互联网 时间:2016-01-03

‘复制当前打开的数据库

'********** 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 = "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

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

'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 ***************

 

相关阅读:
Top