frmdatabase.frm

来自「vb与access数据库的操作实例」· FRM 代码 · 共 136 行

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