前台中备份后台数据库例子

咱家是猫

我是把它们放在"我的文档"文件夹的

1. Option Compare Database
   
2. 
   
3. Function SysSet(SetName As String)
   
4. '提取系统设置的函数
   
5. 
   
6. On Error GoTo Err_SysSet
   
7. 
   
8. SysSet = DLookup("[" & SetName & "]", "备份设置")
   
9. 
   
10. Exit_SysSet:
    
11. Exit Function
    
12. 
    
13. Err_SysSet:
    
14. 
    
15. MsgBox Err.Description
    
16. Resume Exit_SysSet
    
17. 
    
18. End Function
    
19. 
    
20. Sub DefaultBackUp()
    
21. 
    
22. Dim WinRARPath As String
    
23. Dim BackFile As String
    
24. Dim BackPath As String
    
25. Dim BackUpFile As String
    
26. Dim StrCMD As String
    
27. 
    
28. If Not IsNull(SysSet("WinRAR路径")) Then
    
29. WinRARPath = SysSet("WinRAR路径")
    
30. Else
    
31. Do
    
32. WinRARPath = ShowFolderDlg("确认 WinRAR 程序安装的文件夹。")
    
33. 
    
34. If WinRARPath = "" Then
    
35. MsgBox "备份任务取消！" & Chr(13) & Chr(10) & Chr(10) & "未确认 WinRAR.exe 程序的安装路径，系统需要此程序来完成备份任务。", vbInformation, "North Star"
    
36. Exit Sub
    
37. End If
    
38. If Dir(WinRARPath + "\WinRAR.exe") = "" Then
    
39. MsgBox "指定文件夹中未找到 WinRAR.exe 程序！" & Chr(13) & Chr(10) & Chr(10) & "请重新选择。", vbExclamation, "North Star"
    
40. End If
    
41. Loop While Dir(WinRARPath + "\WinRAR.exe") = ""
    
42. End If
    
43. If Not IsNull(SysSet("备份路径")) Then
    
44. BackUpPath = SysSet("备份路径")
    
45. Else
    
46. BackUpPath = ShowFolderDlg("选择一个存放备份数据文件的文件夹。" & Chr(13) & Chr(10) & Chr(13) & "请设置为不同与后台数据路径的另一驱动器路径。")
    
47. If BackUpPath = "" Then
    
48. MsgBox "备份任务取消！" & Chr(13) & Chr(10) & Chr(10) & "您未指定存放备份数据文件的文件夹。", vbInformation, "North Star"
    
49. Exit Sub
    
50. End If
    
51. End If
    
52. BackFile = DLookup("[Database]", "MSysObjects", "Database<>Null")
    
53. BackUpFile = BackUpPath & "\BK" & Format(Date, "yyyymmdd")
    
54. StrCMD = """" & WinRARPath & "\WinRAR.exe"" a -ep -p123456 """ & BackUpFile & """ """ & BackFile & """"
    
55. 
    
56. '压缩备份后台数据库
    
57. Shell StrCMD, vbNormalFocus
    
58. 
    
59. End Sub
    
60. 
    
61. Function ShowFolderDlg(strDialogTitle As String) As String
    
62. '函数作用:使用SHELL对象显示浏览文件夹对话框,返回文件夹路径,这是目前最简单的方式,不需要API函数.
    
63. '函数参考:代码来自OFFICE精英俱乐部
    
64. '函数范例:me.text1=ShowFolderDlg("请选择一个数据库文件......")
    
65. '测试状态:OK
    
66. 
    
67. Dim shApp As Object, Path1 As Object
    
68. Set shApp = CreateObject("Shell.application")
    
69. Set Path1 = shApp.BrowseForFolder(0, strDialogTitle, 0, 17)
    
70. If Path1 Is Nothing Then Exit Function
    
71. ShowFolderDlg = IIf(IsError(Path1.items.Item.Path), Path1.Title, Path1.items.Item.Path)
    
72. 
    
73. End Function
    

复制代码

nienie2010

多谢分享

wuheng

谢谢分享，下了学习~~~~~~~~

wuheng

谢谢分享，下了学习~~~~~~~~

82077802

谢谢分享，下了学习~~~~~~~~

stwuyiyu

谢谢啊，学习了

asklove

收藏，备用，谢谢！

ZenJing

谢谢，下了学习

daviee

弱弱地问一句，在那修改要备份的数据库路径，我的数据不是存放在“我的文档”中。谢谢！

daviee

楼主，用你的这个程序运行正常，导入到我的程序中运行，出现 “此窗体或报表上指定的记录源 RegisterInfo 不存在”，在你程序里怎么也没找到你的这个RegisterInfo源呀？！