前台中备份后台数据库例子 - Office中国论坛/Access中国论坛

Option Compare Database
Function SysSet(SetName As String)
'提取系统设置的函数
On Error GoTo Err_SysSet
SysSet = DLookup("[" & SetName & "]", "备份设置")
Exit_SysSet:
Exit Function
Err_SysSet:
MsgBox Err.Description
Resume Exit_SysSet
End Function
Sub DefaultBackUp()
Dim WinRARPath As String
Dim BackFile As String
Dim BackPath As String
Dim BackUpFile As String
Dim StrCMD As String
If Not IsNull(SysSet("WinRAR路径")) Then
WinRARPath = SysSet("WinRAR路径")
Else
Do
WinRARPath = ShowFolderDlg("确认 WinRAR 程序安装的文件夹。")
If WinRARPath = "" Then
MsgBox "备份任务取消！" & Chr(13) & Chr(10) & Chr(10) & "未确认 WinRAR.exe 程序的安装路径，系统需要此程序来完成备份任务。", vbInformation, "North Star"
Exit Sub
End If
If Dir(WinRARPath + "\WinRAR.exe") = "" Then
MsgBox "指定文件夹中未找到 WinRAR.exe 程序！" & Chr(13) & Chr(10) & Chr(10) & "请重新选择。", vbExclamation, "North Star"
End If
Loop While Dir(WinRARPath + "\WinRAR.exe") = ""
End If
If Not IsNull(SysSet("备份路径")) Then
BackUpPath = SysSet("备份路径")
Else
BackUpPath = ShowFolderDlg("选择一个存放备份数据文件的文件夹。" & Chr(13) & Chr(10) & Chr(13) & "请设置为不同与后台数据路径的另一驱动器路径。")
If BackUpPath = "" Then
MsgBox "备份任务取消！" & Chr(13) & Chr(10) & Chr(10) & "您未指定存放备份数据文件的文件夹。", vbInformation, "North Star"
Exit Sub
End If
End If
BackFile = DLookup("[Database]", "MSysObjects", "Database<>Null")
BackUpFile = BackUpPath & "\BK" & Format(Date, "yyyymmdd")
StrCMD = """" & WinRARPath & "\WinRAR.exe"" a -ep -p123456 """ & BackUpFile & """ """ & BackFile & """"
'压缩备份后台数据库
Shell StrCMD, vbNormalFocus
End Sub
Function ShowFolderDlg(strDialogTitle As String) As String
'函数作用:使用SHELL对象显示浏览文件夹对话框,返回文件夹路径,这是目前最简单的方式,不需要API函数.
'函数参考:代码来自OFFICE精英俱乐部
'函数范例:me.text1=ShowFolderDlg("请选择一个数据库文件......")
'测试状态:OK
Dim shApp As Object, Path1 As Object
Set shApp = CreateObject("Shell.application")
Set Path1 = shApp.BrowseForFolder(0, strDialogTitle, 0, 17)
If Path1 Is Nothing Then Exit Function
ShowFolderDlg = IIf(IsError(Path1.items.Item.Path), Path1.Title, Path1.items.Item.Path)
End Function

复制代码