frm_dbbackup.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form frm_DbBackup 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "备份数据库文件"
   ClientHeight    =   2055
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5610
   Icon            =   "frm_DbBackup.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2055
   ScaleWidth      =   5610
   StartUpPosition =   2  '屏幕中心
   Tag             =   "备份数据库文件"
   Begin VB.CheckBox ChkCDSize 
      Caption         =   "兼容光盘恢复"
      Height          =   300
      Left            =   300
      TabIndex        =   9
      ToolTipText     =   "备份格式是否兼容光盘恢复"
      Top             =   1500
      Width           =   1425
   End
   Begin VB.ComboBox CmbDbInfo 
      Height          =   300
      Left            =   1305
      Style           =   2  'Dropdown List
      TabIndex        =   8
      Top             =   150
      Width           =   3510
   End
   Begin VB.TextBox TxtDbName 
      Height          =   300
      Left            =   1305
      Locked          =   -1  'True
      TabIndex        =   7
      Text            =   "qfjxc-demo"
      Top             =   570
      Width           =   3510
   End
   Begin VB.CommandButton Command3 
      Caption         =   "备 份(&B)"
      Height          =   435
      Left            =   2055
      TabIndex        =   6
      Top             =   1440
      Width           =   1485
   End
   Begin VB.TextBox txtdbPath 
      Height          =   300
      IMEMode         =   3  'DISABLE
      Left            =   1305
      TabIndex        =   5
      Top             =   990
      Width           =   3510
   End
   Begin VB.CommandButton Command4 
      Cancel          =   -1  'True
      Caption         =   "退出(&X)"
      Height          =   435
      Left            =   3630
      TabIndex        =   4
      Top             =   1440
      Width           =   1485
   End
   Begin VB.CommandButton Command1 
      Caption         =   "..."
      Height          =   285
      Left            =   4890
      TabIndex        =   0
      Top             =   998
      Width           =   420
   End
   Begin MSComDlg.CommonDialog Cmdlg 
      Left            =   5040
      Top             =   120
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      DefaultExt      =   "dat"
      DialogTitle     =   "选择账套文件:"
      Filter          =   "*.*"
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "账套名称:"
      Height          =   180
      Index           =   0
      Left            =   405
      TabIndex        =   3
      Top             =   210
      Width           =   810
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "数据库名:"
      Height          =   180
      Index           =   2
      Left            =   405
      TabIndex        =   2
      Top             =   630
      Width           =   810
   End
   Begin VB.Label lblLabels 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "账套文件:"
      Height          =   180
      Index           =   1
      Left            =   405
      TabIndex        =   1
      Top             =   1050
      Width           =   810
   End
End
Attribute VB_Name = "frm_DbBackup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Public mDbID As Long, mDbName As String, mName As String
Dim tmprs As New ADODB.Recordset, CurIdx As Integer

Private Function BackupDB(dbname As String, dbinfo As String, DbPathName As String, Optional BakCdRom As Boolean = False) As Integer
On Error GoTo Er
      
    Me.Caption = "正在备份数据库 " & dbname & "..."
    Screen.MousePointer = vbHourglass
    DoEvents
    Cn.Execute " Backup Database [" & dbname & "] To Disk='" & DbPathName & "'" & vbCrLf & _
                      "  WITH  " & IIf(BakCdRom, " BLOCKSIZE = 2048, ", "") & "  DESCRIPTION=N'帐套备份文件 AT " & Now & "', " & vbCrLf & _
                      " NAME = N'" & IIf(dbinfo = "", "UnKown", dbinfo) & "_Bak' "
     
    DoEvents
    Me.Caption = "备份数据库 " & dbname & " 成功！"
    Screen.MousePointer = vbDefault
    MsgBox "备份数据库 " & dbname & " 到文件 " & DbPathName & " 成功！", vbExclamation, Me.Caption
    
   Exit Function
   
Er:
    Screen.MousePointer = vbDefault
    MsgBox "备份账套数据库 " & dbname & " 失败！错误:" & Err.Number & " 来自:" & Err.Source & vbCrLf & " 详细:" & Err.Description, vbExclamation, "备份账套失败:" & Err.Number
    
End Function

Private Sub CmbDbInfo_Click()
    With CmbDbInfo
        If .ListIndex >= 0 Then
            tmprs.Filter = "FDBID=" & .ItemData(.ListIndex)
            TxtDbName.Text = Trim(tmprs!FDbname)
            mName = tmprs!FName
            mDbName = tmprs!FDbname
            Me.Caption = Me.Tag & " " & mName & " - [" & mDbName & "]  "
        End If
    End With
End Sub

Private Sub Command1_Click()
On Error GoTo Er

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

End Sub

Private Sub Command3_Click()
    If CmbDbInfo.ListIndex >= 0 Then
        If Trim(txtdbPath.Text) = "" Then
            MsgBox "要备份的账套文件不能为空！", vbExclamation, Me.Caption
            txtdbPath.SetFocus
            Exit Sub
        End If
        Call BackupDB(Trim(TxtDbName.Text), Trim(CmbDbInfo.List(CmbDbInfo.ListIndex)), Trim(txtdbPath.Text), ChkCDSize.Value = 1)
        Me.Caption = Me.Tag
    End If
End Sub

Private Sub Command4_Click()
    Unload Me
End Sub

Private Sub Form_Load()
On Error GoTo Er
    Set tmprs = Cn.Execute("select a.dbid AS FDBID,a.name AS FDBName, a.name AS FName ,a.dbID AS FID  from master..sysdatabases a " & _
                "  Where  a.dbid>4 Order By a.dbid ")
    Set tmprs.ActiveConnection = Nothing
    With CmbDbInfo
        .Clear
        Do While Not tmprs.EOF
            .AddItem tmprs!FName '& "  -   " & tmprs!FDbname
            .ItemData(.ListCount - 1) = tmprs!FDBID
            If tmprs!FDBID = mDbID Then CurIdx = .ListCount - 1
            tmprs.MoveNext
        Loop
        If .ListCount > 0 And .ListIndex < 0 Then .ListIndex = CurIdx
    End With
    Exit Sub
Er:
    MsgBox "错误:" & Err.Number & " 来自:" & Err.Source & vbCrLf & " 详细:" & Err.Description, vbExclamation, "取数据库信息错误:" & Err.Number
End Sub

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