frm_main.frm

1.数数库的分离与附加 2 自动查找数据库

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form Frm_Main 
   Caption         =   "数据库管理工具"
   ClientHeight    =   1980
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5505
   Icon            =   "Frm_Main.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   1980
   ScaleWidth      =   5505
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command5 
      Caption         =   "修改密码"
      Height          =   435
      Left            =   120
      TabIndex        =   10
      Top             =   1380
      Width           =   615
   End
   Begin VB.CommandButton Command1 
      Caption         =   "..."
      Height          =   285
      Left            =   4380
      TabIndex        =   9
      Top             =   968
      Width           =   420
   End
   Begin VB.TextBox txtdbPath 
      Height          =   300
      IMEMode         =   3  'DISABLE
      Left            =   1260
      TabIndex        =   8
      Top             =   960
      Width           =   3090
   End
   Begin VB.CommandButton Command4 
      Caption         =   "高级"
      Height          =   375
      Left            =   4710
      TabIndex        =   7
      Top             =   1410
      Width           =   765
   End
   Begin VB.TextBox TxtDbName 
      Height          =   300
      Left            =   1260
      TabIndex        =   4
      Text            =   "qfjxc-demo"
      Top             =   540
      Width           =   3090
   End
   Begin VB.CommandButton Command3 
      Cancel          =   -1  'True
      Caption         =   "退 出(&X)"
      Height          =   375
      Left            =   2940
      TabIndex        =   3
      Top             =   1395
      Width           =   1395
   End
   Begin VB.CommandButton Command2 
      Caption         =   "恢复账套"
      Height          =   375
      Left            =   1290
      TabIndex        =   2
      Top             =   1395
      Width           =   1455
   End
   Begin MSComDlg.CommonDialog Cmdlg 
      Left            =   4980
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DefaultExt      =   "dat"
      DialogTitle     =   "选择账套文件:"
      Filter          =   "*.*"
   End
   Begin VB.TextBox txtUserName 
      Height          =   300
      Left            =   1260
      TabIndex        =   0
      Text            =   "演示帐套"
      Top             =   120
      Width           =   3090
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "账套文件:"
      Height          =   180
      Index           =   1
      Left            =   315
      TabIndex        =   6
      Top             =   1020
      Width           =   810
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "数据库名:"
      Height          =   180
      Index           =   2
      Left            =   315
      TabIndex        =   5
      Top             =   600
      Width           =   810
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "账套名称:"
      Height          =   180
      Index           =   0
      Left            =   315
      TabIndex        =   1
      Top             =   180
      Width           =   810
   End
End
Attribute VB_Name = "Frm_Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim strDbName As String
Dim dbname As String

Private Sub Command1_Click()

On Error GoTo Er

    With Cmdlg
        .CancelError = True
        .InitDir = strPath
        .ShowOpen
        strDbName = Trim(.FileName)
        txtdbPath.Text = strDbName
    End With
    Exit Sub
    
Er:
    Exit Sub
End Sub

Private Sub Command2_Click()
Dim rs As Recordset, DbPath As String, str
Dim mfname As String, lfname As String, bakname As String, Name As String, tmppath As String

On Error GoTo Er
    
    strDbName = Trim(txtdbPath.Text)
    If Trim(txtdbPath.Text) = "" Then
        MsgBox "要恢复的账套文件不能为空！", vbExclamation, Me.Caption
        txtdbPath.SetFocus
        Exit Sub
    End If
    dbname = Trim(TxtDbName.Text)
    If dbname = "" Then
        MsgBox "数据库名不能为空！", vbExclamation, Me.Caption
        TxtDbName.SetFocus
        Exit Sub
    End If
    If Trim(txtUserName.Text) = "" Then
        MsgBox "账套名称不能为空！", vbExclamation, Me.Caption
        txtUserName.SetFocus
        Exit Sub
    End If
    
    Set rs = Cn.Execute("select Name from master..sysdatabases Where Name='" & dbname & "'")
    If Not (rs.EOF And rs.BOF) Then
        If MsgBox("警告：已有相同的数据库 " & dbname & " 存在,此操作数据库将会被覆盖，是否继续？", vbYesNo + vbExclamation, Me.Caption) = vbNo Then Exit Sub
    End If
    
    Command2.Enabled = False
    Me.MousePointer = vbHourglass
    
    '取账套备份文件信息
    If g_GetBakDbInfo(strDbName, bakname, Name, mfname, lfname, tmppath) = 0 Then
    
        With Cn
            
            Set rs = .Execute("select top 1 filename from master..sysfiles")
            str = Split(rs(0), "\")
            DbPath = Replace(rs(0), str(UBound(str)), "")
            
            'Restore The Db
            .Execute (" Restore Database [" & dbname & "] from disk='" & strDbName & "' WITH RECOVERY," & _
                      "Move '" & mfname & "' TO '" & DbPath & dbname & ".mdf" & _
                      "',Move '" & lfname & "' TO '" & DbPath & dbname & ".ldf" & "',REPLACE")
                      
'             'Register The Db On the qfMaster
'
'             .Execute ("Insert Into qfmaster..db values('" & Trim(TxtUserName.Text) & "'" & _
'                    ",'" & dbname & "','" & Format(Date, "YYYY-MM-DD") & "','" & Format(Date, "YYYY-MM-DD") & "',2,'1.0')")
                      
        End With
    End If
    
    Command2.Enabled = True
    Me.MousePointer = vbDefault
    MsgBox "恢复账套成功！", vbExclamation, Me.Caption
    
    Exit Sub
Er:
    MsgBox "错误:" & Err.Number & " 来自:" & Err.Source & vbCrLf & " 详细:" & Err.Description, vbExclamation, "错误:" & Err.Number
    Command2.Enabled = True
    Me.MousePointer = vbDefault
End Sub

'取指定数据库备份文件中的数据库信息
'mfname 主数据库文件名,lfname 数据库日志文件名
Private Function g_GetBakDbInfo(dbfile As String, bakname As String, dbname As String, mfname As String, lfname As String, fpath As String) As Integer
Dim bol_rsopen As Boolean
Dim tmprs As ADODB.Recordset
Dim bakdes As String
Dim username As String

On Error GoTo Er
    
     bol_rsopen = False
     Set tmprs = Cn.Execute(" Restore FileListOnly From Disk='" & dbfile & "' With File=1,NoUnLoad", , adCmdText)
     If Not tmprs.EOF Then
     
         mfname = tmprs.Fields(0)
         tmprs.MoveNext
         lfname = tmprs.Fields(0)
         
         tmprs.Close
         Set tmprs = Nothing
         bol_rsopen = False
         
         g_GetBakDbInfo = 0
         Exit Function
         
      Else
      
          GoTo Er
          
     End If
  
  Exit Function
  
Er:
 
  If bol_rsopen Then
      tmprs.Close
      Set tmprs = Nothing
  End If
  
  MsgBox "取账套备份文件信息错误！", vbExclamation, dbfile
  
  g_GetBakDbInfo = -1
  
End Function

Private Sub Command3_Click()
    Unload Me
End Sub

Private Sub Command4_Click()
    Frm_Main.Hide
    frm_DbRegister.Show 1
    Frm_Main.Show 1
End Sub

Private Sub Command5_Click()
    frm_ChgPwd.Show 1
End Sub

Private Sub Form_Load()
    Me.Caption = Me.Caption & " - [" & SvrName & "]"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
    Cn.Close
    Set Cn = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set Frm_Main = Nothing
End Sub