【VB开源代码栏目提醒】:网学会员在VB开源代码频道为大家收集整理了FrmDataBase.frm提供大家参考,希望对大家有所帮助!
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmDataBase
Caption = "数据库备份恢复和压缩"
ClientHeight = 4170
ClientLeft = 60
ClientTop = 345
ClientWidth = 3600
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4170
ScaleWidth = 3600
StartUpPosition = 2 '屏幕中心
Begin MSComDlg.CommonDialog CommonDialog1
Left = 2760
Top = 2160
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Cmd_Back
Caption = "返 回"
Height = 495
Left = 840
TabIndex = 3
Top = 3120
Width = 1815
End
Begin VB.CommandButton Cmd_Restore
Caption = "数据库恢复"
Height = 495
Left = 840
TabIndex = 2
Top = 2160
Width = 1815
End
Begin VB.CommandButton Cmd_BackUp
Caption = "数据库备份"
Height = 495
Left = 840
TabIndex = 1
Top = 1320
Width = 1815
End
Begin
VB.CommandButton Cmd_Compact
Caption = "数据库压缩"
Height = 495
Left = 840
TabIndex = 0
Top = 480
Width = 1815
End
End
Attribute VB_Name = "FrmDataBase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim newdb As String '压缩后的数据库文件名
Dim olddb As String '待压缩数据库文件名
Private Sub Cmd_Back_Click()
Unload Me
End Sub
Private Sub Cmd_BackUp_Click()
Dim Fs As FileSystemObject
Dim BackUpFile As String
olddb = App.Path + "\" + DBName
BackUpFile = App.Path + "\Backup\" + Str(Date) + "_" + DBName
If MsgBox("你确定要备份当前数据库吗?", vbQuestion + vbOKCancel _
+ vbDefaultButton2, "请确认") = vbCancel Then
Exit Sub
End If
Set Fs = CreateObject("Scripting.FileSystemObject")
'拷贝数据库文件至指定位置
Fs.CopyFile olddb, BackUpFile
MsgBox "数据库备份成功", vbInformation + vbOKOnly, "信息"
End Sub
Private Sub Cmd_Compact_Click()
On Error GoTo Myerr
Dim rdo As New JRO.JetEngine
Dim strcnn_old As String
Dim strcnn_new As String
newdb = App.Path + "\temp.mdb" ' 创建临时文件名
olddb = App.Path + "\" + DBName
'确认是否进行压缩处理
If MsgBox("你确定要
压缩当前数据库吗?", vbQuestion + vbOKCancel _
+ vbDefaultButton2, "请确认") = vbCancel Then
Exit Sub
End If
'如果newdb存在,则删除
If Dir(newdb) <> "" Then
Kill newdb
End If
'设置连接字符串
strcnn_old = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + olddb
strcnn_new = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + newdb
'先关闭全局连接
DBapi_Disconnect
'压缩数据库文件
rdo.CompactDatabase strcnn_old, strcnn_new
DoEvents '考虑到连接是
网络中的数据库时
Kill olddb '删除原来的文件
Name newdb As olddb '将压缩后的数据库文件名称改回去
DB_Connect '再开启全局连接
MsgBox "数据库压缩成功", vbInformation + vbOKOnly, "信息"
Exit Sub
'错误处理
Myerr:
MsgBox Err.Number & Err.Description & Chr(13) _
+ "压缩数据库不成功,请关闭Access,重新登录
系统", vbExclamation
DB_Connect
End Sub
Private Sub Cmd_Restore_Click()
CommonDialog1.ShowOpen
newdb = CommonDialog1.FileName
olddb = App.Path + "\" + DBName
If MsgBox("你确定要恢复以前的数据库吗?这将导致新的数据丢失!", _
vbQuestion + vbOKCancel + vbDefaultButton2, "小心!") = vbCancel Then
Exit Sub
End If
'关闭数据库连接
DBapi_Disconnect
Kill olddb '删除原来的文件
Set Fs = CreateObject("Scripting.FileSystemObject")
'拷贝数据库文件至指定位置
Fs.CopyFile newdb, olddb
DB_Connect '再开启全局连接
MsgBox "数据库恢复成功", vbInformation + vbOKOnly, "信息"
End Sub