Access911.net   |   a9BBS   |   OTaA System  
  搜索文章:  
Access911欢迎您光临  
   主页      上传      繁體版       论坛     
设为首页  |  加入收藏   
  
你现在的位置:文章索引 -> 文章分类 -> 其他  
 首页|  近日更新|  下载  |  文章索引  |  搜索|  术语|  承接工程|  
 
系统正在加载内容,请耐心等待...
 
 查询
 窗体
 报表
 
 
 VBA
 函数
 ADO/DAO/ADO.NET
 API
 ADP
 安全
 发布
 OA
 ASP/ASP.NET
 其他语言
 控件
 DELPHI
 C#/.Net
 本站
 其他
 小例程
 常用软件
 参考文档
 业主作品
 网友大作
 
 
友情链接
 access911.net
 
访问人次
 1702696
 
站长 E-Mail
 net911@sina.com
 access911@gmail.com
 
RSS 订阅

显示附加信息 >>>

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

作者:未详  摘自:未详  :cg1  更新日期:2003-1-4  浏览人次:

 

‘复制当前打开的数据库
'********** 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 ***************

 

 
相关文章
     没有手动相关文章
 
评论
     查看或发表更多的评论,请单击这里。
 
 
 
 
 
   
  Access911.net   |   a9BBS   |   OTaA System   |
建站日期:2000年4月2日  |  设计施工:陈格 ( access911 & cg1 )
 Copyright © 2000 - 2003 COMET, 陈格 保留所有权利