frmrestoreandbackup.frm

本系统可用于医院和专业体检中心的健康体检管理

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{0B81E4A9-BE4E-4AEF-9272-33AB5B51C6FC}#1.0#0"; "XPControls.ocx"
Begin VB.Form frmRestoreAndBackup 
   BackColor       =   &H00D3DABC&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "备份/还原数据库"
   ClientHeight    =   5040
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   7110
   Icon            =   "frmRestoreAndBackup.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5040
   ScaleWidth      =   7110
   StartUpPosition =   1  '所有者中心
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   270
      Top             =   4410
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H00D3DABC&
      Caption         =   "选择路径"
      Height          =   3945
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   6855
      Begin VB.FileListBox File1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   3450
         Left            =   3000
         TabIndex        =   6
         Top             =   360
         Width           =   3615
      End
      Begin VB.DirListBox Dir1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   2790
         Left            =   240
         TabIndex        =   5
         Top             =   1020
         Width           =   2655
      End
      Begin VB.DriveListBox Drive1 
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   360
         Left            =   240
         TabIndex        =   4
         Top             =   360
         Width           =   2655
      End
   End
   Begin XPControls.XPCommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   465
      Left            =   4950
      TabIndex        =   0
      Top             =   4380
      Width           =   1275
      _ExtentX        =   2249
      _ExtentY        =   820
      Caption         =   "取  消(&C)"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdBackup 
      Height          =   465
      Left            =   870
      TabIndex        =   1
      Top             =   4380
      Width           =   1275
      _ExtentX        =   2249
      _ExtentY        =   820
      Caption         =   "备份数据库(&B)"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin XPControls.XPCommandButton cmdRestore 
      Height          =   465
      Left            =   2910
      TabIndex        =   2
      Top             =   4380
      Width           =   1275
      _ExtentX        =   2249
      _ExtentY        =   820
      Caption         =   "恢复数据库(&R)"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmRestoreAndBackup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdBackup_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strPath As String
    Dim strDate As String
    Dim strLog As String
    Dim con As ADODB.Connection
    
    '获取备份到的含斜杠“\”的文件夹
    strPath = Dir1.Path
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    
    If MsgBox("确实要备份数据库到路径“" & strPath & "吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "询问") = vbNo Then GoTo ExitLab
    
    Me.MousePointer = vbHourglass
    strDate = Format(Now, "yyyymmddHhNnSs")
    strSQL = "BACKUP database " & DatabaseName & " TO DISK='" _
            & strPath & DatabaseName & strDate & ".bak'" _
            & " WITH RESTART"
    
    CloseRS
    Set con = New ADODB.Connection
    con.ConnectionString = GetDatabaseParameter("master")
    con.Open
    con.Execute strSQL
    Me.MousePointer = vbDefault
    
    MsgBox "备份成功！" & vbCrLf & vbCrLf & "*备份文件名为：" & vbTab & vbTab _
            & DatabaseName & strDate & ".bak" _
            & vbCrLf & "*备份文件所在的路径为：" _
            & vbTab & strPath, vbInformation, "祝贺"
    strLog = "成功备份数据库！" & "*备份文件名为：" _
            & DatabaseName & strDate & ".bak，" _
            & "*备份文件所在的路径为：" & strPath
    '添加到日志
'    AddLog gstrManagerName, strLog, OperationLog
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description _
            & vbCrLf & "请确认您有访问数据库服务器的全部权限，以及当前没有其他人正在使用数据库！", _
            Me.Caption & ".cmdBackup_Click")
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdBackup_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "备份数据库"
End Sub

Private Sub cmdCancel_Click()
    Me.Hide
    Unload Me
End Sub

Private Sub cmdCancel_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "关闭当前窗体"
End Sub

Private Sub cmdRestore_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strDate As String   '记录备份文件的日期，字符串形式
    Dim dteDate As Date     '记录备份文件的日期，日期形式
    Dim strMsg As String
    Dim strSQLRestore, strSQLDelete As String
    Dim strPath As String
    Dim con As ADODB.Connection
    Dim strFileName As String
    Dim strConnectString As String
    
    '***********************************************************************
    '                               权限控制
    '***********************************************************************
'    If gstrClassifyID <> "00001" Then
'        MsgBox "你没有控制权限，请用管理员帐户登录！", vbExclamation, "警告"
'        GoTo ExitLab
'    End If
    '///////////////////////////////////////////////////////////////////////
    
    '获取备份文件所在的含斜杠“\”的文件夹
    strPath = Dir1.Path
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    strFileName = GetFileName(Me.CommonDialog1, "数据库备份文件（*.bak）|*.bak", _
            "选择数据库备份文件", , READFILE)
    If strFileName = "" Then GoTo ExitLab

'    If UCase(Right(strFileName, 3)) <> "BAK" Or _
'            Len(strFileName) <> 18 + Len(DatabaseName) Or _
'            Mid(strFileName, 1, Len(DatabaseName)) <> DatabaseName Then
    If UCase(Right(strFileName, 3)) <> "BAK" Then
        MsgBox "所选文件不是本软件备份的数据库文件！请重新选择！", _
                vbExclamation, "警告"
        GoTo ExitLab
    End If
    
    strMsg = "还原操作将用你选中的备份文件覆盖原来的数据库文件，" _
            & "在该备份文件之后的数据将被丢弃！" & vbCrLf & "该操作不可恢复！" _
            & vbCrLf & vbCrLf & "确定要用数据文件“" & strFileName & "”还原吗？？"
    If MsgBox(strMsg, vbQuestion + vbYesNo + vbDefaultButton2, "三思而后行") = vbNo Then
        GoTo ExitLab
    End If
    
    strDate = Mid(strFileName, InStrRev(strFileName, "\", , vbTextCompare) + 1, Len(strFileName) - InStrRev(strFileName, "\", , vbTextCompare))
    strDate = Mid(strDate, Len(DatabaseName) + 1) '截取日期
    strDate = Left(strDate, Len(strDate) - 4)
    dteDate = Mid(strDate, 1, 4) & "-" & Mid(strDate, 5, 2) _
            & "-" & Mid(strDate, 7, 2) & " " & Mid(strDate, 9, 2) _
            & ":" & Mid(strDate, 11, 2) & ":" & Mid(strDate, 13, 2)
    strMsg = "采用该文件恢复数据库将导致日期 “" & dteDate & "” 之后的数据全部丢失！" & vbCrLf _
            & vbCrLf & "确认要继续吗？"
    If MsgBox(strMsg, vbQuestion + vbYesNo + vbDefaultButton2, "警告") = vbNo Then
        GoTo ExitLab
    End If
    
    Me.MousePointer = vbHourglass
    
'    strSQLRestore = "RESTORE DATABASE " & DatabaseName & " FROM DISK = '" _
'            & strPath & File1.FileName _
'            & "' with replace,norecovery," _
'            & " MOVE '" & DatabaseName & "_data' TO '" _
'            & gstrCurrPath & DatabaseDir & DatabaseName & "_data.mdf'" _
'            & ",MOVE '" & DatabaseName & "_log' TO '" _
'            & gstrCurrPath & DatabaseDir & DatabaseName & "_log.ldf'" _
'            & ",replace,restart"
'    strSQLRestore = "RESTORE DATABASE " & DatabaseName & " FROM DISK = '" _
'            & strPath & File1.FileName & "' with replace,norecovery,restart"

'    strSQLRestore = "RESTORE DATABASE " & DatabaseName & " FROM DISK = '" _
'            & strPath & File1.FileName _
'            & "' with " _
'            & " MOVE 'dhtj_data' TO '" _
'            & gstrCurrPath & DatabaseDir & "dhtj.mdf'" _
'            & ",MOVE 'dhtj_log' TO '" _
'            & gstrCurrPath & DatabaseDir & "dhtj_log.ldf'"
    
    strSQLRestore = "RESTORE DATABASE " & DatabaseName & " FROM DISK = '" _
            & strFileName _
            & "' with " _
            & " MOVE 'dhtj_data' TO '" _
            & strPath & "dhtj.mdf'" _
            & ",MOVE 'dhtj_log' TO '" _
            & strPath & "dhtj_log.ldf'"
    
    If Dir(strPath & DatabaseName & "_data.MDF", vbNormal) <> "" Then
        Kill strPath & DatabaseName & "_data.MDF"
    End If
    
    CloseRS
'    GCon.Close
    Set GCon = Nothing
    
    Set con = New ADODB.Connection
    con.ConnectionString = GetDatabaseParameter("master")
    con.Open
    con.Execute strSQLRestore
    con.Close
    Set con = Nothing
    
    ConnectDatabase GCon
     
    Me.MousePointer = vbDefault
    MsgBox "数据库恢复成功！", vbInformation, "祝贺"
    
    '添加到日志
'    AddLog gstrManagerName, "成功恢复数据库。所用的备份文件为：" & File1.FileName & "，该备份文件生成的时间为：" & dteDate, OperationLog
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description _
            & vbCrLf & "请确认您有访问数据库服务器的全部权限，以及当前没有其他人正在使用数据库！", _
            Me.Caption & ".cmdRestore_Click")
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdRestor1e_Click()

End Sub

Private Sub cmdRestore_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "恢复数据库"
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub Dir1_Click()
    Dir1.Path = Dir1.List(Dir1.ListIndex)
End Sub

Private Sub Dir1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "选择路径"
End Sub

Private Sub Drive1_Change()
On Error Resume Next
    Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "选择文件"
End Sub

Private Sub Form_Load()
    '***********************************************************************
    '                               权限控制
    '***********************************************************************
'    If gstrClassifyID <> "00001" Then
'        cmdRestore.Enabled = False
'    End If
    '///////////////////////////////////////////////////////////////////////
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "Ready"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    ShowStatus "Ready"
    
'    Me.Hide
'    Set frmRestoreAndBackup = Nothing
End Sub

Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    ShowStatus "选择路径"
End Sub