form_restoredatabase.frm

适合于中小型企业管理

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form Frm_RestoerDatabase 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "帐套恢复"
   ClientHeight    =   4215
   ClientLeft      =   3165
   ClientTop       =   1890
   ClientWidth     =   7830
   HelpContextID   =   1018
   Icon            =   "Form_RestoreDatabase.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4215
   ScaleWidth      =   7830
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Cmd_Del 
      Caption         =   "删除(&D)"
      Height          =   285
      Left            =   6300
      TabIndex        =   13
      ToolTipText     =   "删除备份文件"
      Top             =   3330
      Width           =   1245
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Index           =   3
      Left            =   5850
      Locked          =   -1  'True
      TabIndex        =   12
      Top             =   2460
      Width           =   1635
   End
   Begin VB.CommandButton Cmd_Path 
      Height          =   315
      Left            =   7470
      Picture         =   "Form_RestoreDatabase.frx":0ECA
      Style           =   1  'Graphical
      TabIndex        =   10
      Top             =   2460
      Width           =   315
   End
   Begin VB.CommandButton Cmd_Cancel 
      Caption         =   "取消(&C)"
      Height          =   285
      Left            =   6300
      TabIndex        =   9
      Top             =   3750
      Width           =   1245
   End
   Begin VB.CommandButton cmd_restore 
      Caption         =   "恢复(&R)"
      Height          =   285
      Left            =   6300
      TabIndex        =   8
      ToolTipText     =   "恢复套帐"
      Top             =   2910
      Width           =   1245
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Index           =   2
      Left            =   5850
      TabIndex        =   7
      Top             =   1740
      Width           =   1635
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Index           =   1
      Left            =   5850
      TabIndex        =   6
      Top             =   1020
      Width           =   1635
   End
   Begin VB.TextBox Text1 
      Height          =   285
      Index           =   0
      Left            =   5850
      TabIndex        =   3
      Top             =   360
      Width           =   1635
   End
   Begin VB.Frame Frame1 
      Caption         =   "备份文件"
      Height          =   4155
      Left            =   30
      TabIndex        =   0
      Top             =   30
      Width           =   5685
      Begin MSComctlLib.ListView List_data 
         Height          =   3915
         Left            =   60
         TabIndex        =   1
         Top             =   180
         Width           =   5565
         _ExtentX        =   9816
         _ExtentY        =   6906
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         FullRowSelect   =   -1  'True
         _Version        =   393217
         ForeColor       =   -2147483640
         BackColor       =   -2147483643
         BorderStyle     =   1
         Appearance      =   1
         BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
            Name            =   "宋体"
            Size            =   9
            Charset         =   134
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         NumItems        =   4
         BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            Text            =   "数据库名"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   1
            Text            =   "备份文件名"
            Object.Width           =   2540
         EndProperty
         BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   2
            Text            =   "备份时间"
            Object.Width           =   3881
         EndProperty
         BeginProperty ColumnHeader(4) {BDD1F052-858B-11D1-B16A-00C0F0283628} 
            SubItemIndex    =   3
            Text            =   "备份路径"
            Object.Width           =   8819
         EndProperty
      End
   End
   Begin VB.Label Label1 
      Caption         =   "路径:"
      Height          =   165
      Index           =   3
      Left            =   5850
      TabIndex        =   11
      Top             =   2250
      Width           =   795
   End
   Begin VB.Label Label1 
      Caption         =   "数据库名:"
      Height          =   165
      Index           =   2
      Left            =   5850
      TabIndex        =   5
      Top             =   1500
      Width           =   795
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "套帐名称:"
      Height          =   180
      Index           =   1
      Left            =   5850
      TabIndex        =   4
      Top             =   840
      Width           =   810
   End
   Begin VB.Label Label1 
      Caption         =   "编号:"
      Height          =   255
      Index           =   0
      Left            =   5850
      TabIndex        =   2
      Top             =   150
      Width           =   795
   End
End
Attribute VB_Name = "Frm_RestoerDatabase"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'修改人：刘刚 2002-12-18

Dim mitem As ListItem
Dim R_SQLSERVER As String
Dim R_USERID As String
Dim R_PASSWORD As String

Private Function fun_PrepareCreateOK(sInfo As String) As Boolean
'检测新建数据库等各种条件是否成熟，sInfo 负责返回错误信息 by lg 2002-12-17
Dim sSql As String
Dim rs As New ADODB.Recordset
Dim sTmp As String
    
    fun_PrepareCreateOK = False
    
    If Trim(Text1(0).Text) = "" Then sTmp = "帐套编码不能为空！ ": Text1(0).SetFocus: GoTo errD
    If Trim(Text1(1).Text) = "" Then sTmp = "帐套名称不能为空！ ": Text1(1).SetFocus: GoTo errD
    If Trim(Text1(2).Text) = "" Then sTmp = "数据库名不能为空！ ": Text1(2).SetFocus: GoTo errD
    If IsNumeric(Text1(2).Text) Then sTmp = "数据库名不能为数值！ ": Text1(2).SetFocus: GoTo errD
    If Trim(Text1(3).Text) = "" Then
        sTmp = "数据库保存路径不能为空！ ": Text1(3).SetFocus: GoTo errD
    Else
        If Dir(Trim(Text1(3).Text), vbDirectory) = "" Then sTmp = "数据库保存路径不存在!": GoTo errD
    End If
    
    If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close
    Cw_DataEnvi.Connection2.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & R_SQLSERVER & "; Initial Catalog=EboSys;", R_USERID, R_PASSWORD
    
    sSql = "SELECT * FROM  EboSys..Ebo_DataBases WHERE Number='" & Trim(Text1(0).Text) & "'"
    Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
    If Not rs.EOF Then
        sTmp = "帐套编码不能重复！": GoTo errD
    End If
    
    
    If rs.state = 1 Then rs.Close
    sSql = "SELECT * FROM  EboSys..Ebo_DataBases WHERE CountingRoomName='" & Trim(Text1(1).Text) & "'"
    Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
    If Not rs.EOF Then
        sTmp = "帐套名称不能重复！": GoTo errD
    End If
    
    If rs.state = 1 Then rs.Close
    sSql = "SELECT * FROM  EboSys..Ebo_DataBases WHERE DataBasesName='" & Trim(Text1(2).Text) & "'"
    Set rs = Cw_DataEnvi.Connection2.Execute(sSql)
    If Not rs.EOF Then
        sTmp = "数据库名不能重复！": GoTo errD
    End If
    
    If Dir(App.Path & "\" & DBphyFileName & ".bak") = "" Then
        sTmp = "数据源文文件不存在!(" & App.Path & "\" & DBphyFileName & ".bak)": GoTo errD
    End If
    
    fun_PrepareCreateOK = True
errD:
    If Trim(sTmp) = "" Then sTmp = "未知错误!"
    sInfo = sTmp
End Function

Private Sub sub_RestoreDB()
'恢复备份的数据库 by lg 2002-12-18
Dim sInfo As String
Dim sSql As String, NewDBName As String, NewDBPath As String
Dim BakDBName As String, BakDBFileName As String
Dim CountingRoomName As String, Number As String
Dim ServerName As String, DBType As String

    If List_data.ListItems.count < 1 Then MsgBox "没有可恢复的数据库！ ", 16: Exit Sub
    
    YesNoStr = MsgBox("你是否要恢复数据库名为(" & List_data.SelectedItem.Text & ")和数据库备份文件名为(" & List_data.SelectedItem.SubItems(1) & ")的帐套？  ", vbYesNo + 32)
    If YesNoStr = vbNo Then Exit Sub

    On Error GoTo Exit_error
    '准备参数
    
    R_SQLSERVER = Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "ServerName"))
    R_USERID = Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "UserID"))
    R_PASSWORD = Mmjm2(Trim(GetSetting(Ebo_gsProductName, Ebo_gsPrjName, "Password")))
    If Not fun_PrepareCreateOK(sInfo) Then MsgBox sInfo, vbCritical: Exit Sub
    
    NewDBName = Trim(Text1(2).Text): NewDBPath = Trim(Text1(3).Text): BakDBName = List_data.SelectedItem.SubItems(1)
    BakDBFileName = DBlogicFileName: CountingRoomName = Trim(Text1(1).Text)
    Number = Trim(Text1(0).Text): ServerName = R_SQLSERVER: DBType = "SQL Server 2000"

    
    '测试连接
    setStatusBar "正在检测数据库信息...", False
    Me.MousePointer = 12
    If Conn_System1.state = 1 Then Conn_System1.Close
    Conn_System1.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & R_SQLSERVER & "; Initial Catalog=EboSys;", R_USERID, R_PASSWORD
    setStatusBar "", True
    Me.MousePointer = 0
    setStatusBar "正在恢复帐套信息...", False
    Me.MousePointer = 12
    '恢复数据库
    If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close
    Cw_DataEnvi.Connection2.Open "Provider=SQLOLEDB.1;Persist Security Info=False;Data Source=" & R_SQLSERVER & "; Initial Catalog=EboSys;", R_USERID, R_PASSWORD
    
    sSql = "RESTORE DATABASE " & NewDBName & " FROM DISK = '" & List_data.SelectedItem.SubItems(3) & "\" & BakDBName & ".bak' " & Chr(10) _
           & " WITH MOVE '" & BakDBFileName & "_data'" & " TO '" & NewDBPath & "\" & NewDBName & ".mdf' ," & Chr(10) _
           & " MOVE '" & BakDBFileName & "_log'" & " TO  '" & NewDBPath & "\" & NewDBName & ".ldf'"

    Cw_DataEnvi.Connection2.Execute sSql
    
    '填写登记表

    sSql = "INSERT INTO EboSys..Ebo_DataBases(DataBasesName, Number, CountingRoomName, NewDate,   ServerName, DatabaseType, YNuse, CoName,  qsqj)" _
            & " VALUES('" & NewDBName & "','" & Number & "','" & CountingRoomName & "',GETDATE(),'" & ServerName & "','" & DBType & "','0','江苏南通倪老师电脑科技','1') "

    Call Cw_DataEnvi.Connection2.Execute(sSql)

    setStatusBar "", True
    Me.MousePointer = 0
    
    If Cw_DataEnvi.Connection2.state = 1 Then Cw_DataEnvi.Connection2.Close

    Form_main.Form_Load
    MsgBox "帐套恢复成功！ ", 64
    Unload Me
    Exit Sub
    
    '-----------------
Exit_error:
    setStatusBar "", True
    Me.MousePointer = 0
    Select Case Err.Number
           Case -2147467259
                 MsgBox "数据服务器错误！", 16
           Case -2147217843
                MsgBox "用户名或口令错误！", 16
           Case Else
                MsgBox Err.Description & "(" & Err.Number & ")", 16
    End Select

End Sub


Private Sub Cmd_Del_Click()
On Error GoTo Exit_error

    Dim DiskFile As String
    If List_data.ListItems.count < 1 Then MsgBox "没有可删除的备份文件！ ", 16: Exit Sub
    
    YesNoStr = MsgBox("你是否要删除文件名为(" & List_data.SelectedItem.SubItems(1) & ")的数据库备份文件？  ", vbYesNo + 32)
    If YesNoStr = vbNo Then Exit Sub
    DiskFile = Trim(List_data.SelectedItem.SubItems(3)) + "\" + Trim(List_data.SelectedItem.SubItems(1)) + ".Bak"
    If Len(Dir$(DiskFile)) > 0 Then
        Kill DiskFile
    End If
    Conn_System.Execute "delete  EboSys..Ebo_BakDataBases where Number=" & Mid(List_data.SelectedItem.Key, 2, Len(List_data.SelectedItem.Key))
    Form_Load
    Exit Sub
    
Exit_error:
    
       MsgBox Err.Description & "(" & Err.Number & ")", 16
 
End Sub


Private Sub cmd_restore_Click()
    sub_RestoreDB
End Sub

Private Sub Form_Load()
    Dim aDo_Bakdatabase As New Recordset
    Set aDo_Bakdatabase = Conn_System.Execute("select * from EboSys..Ebo_BakDataBases")
    With aDo_Bakdatabase
    List_data.ListItems.Clear
    Do While Not .EOF
        Set mitem = List_data.ListItems.Add()
        mitem.Text = !DataBaseName
        mitem.SubItems(1) = !BakName
        mitem.SubItems(2) = !BakDate
        mitem.SubItems(3) = !BakPath
        mitem.Key = "T" & !Number
       
        .MoveNext
    Loop
    .Close
    Set aDo_Bakdatabase = Nothing
    End With
    
    If List_data.ListItems.count > 0 Then
       Text1(3).Text = App.Path
       Text1(1).Text = List_data.SelectedItem.Text
       Text1(1).Tag = List_data.SelectedItem.SubItems(1)
       Text1(2).Text = List_data.SelectedItem.Text
    End If
End Sub

Private Sub List_data_ItemClick(ByVal Item As MSComctlLib.ListItem)
   Text1(1).Text = List_data.SelectedItem.Text
   Text1(1).Tag = List_data.SelectedItem.SubItems(1)
   Text1(2).Text = List_data.SelectedItem.Text
End Sub

Private Function Mmjm2(Srmm As String) As String                  '密码解密模块
   Dim Zfcte As Integer
   Mmjm2 = ""
   For Jsqte = 1 To Int(Len(Srmm) / 3)
       Zfcte = Val(Mid(Srmm, (Jsqte - 1) * 3 + 1, 3)) - Int(Len(Srmm) / 3) - Jsqte
       Mmjm2 = Mmjm2 + Chr(Zfcte)
   Next Jsqte
End Function

Private Sub Text1_Change(Index As Integer)
    If Index = 3 Then
       If Len(Trim(Text1(3).Text)) = 3 Then Text1(3).Text = Mid(Trim(Text1(3)), 1, 2)
    End If
End Sub

Private Sub Cmd_Cancel_Click()
    Unload Me
End Sub

Private Sub Cmd_Path_Click()
    Frm_Path.Show 1
    If PathStr <> "" Then Text1(3).Text = PathStr
End Sub