frmbackup.frm

自己写的

VERSION 5.00
Begin VB.Form frmBackup 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "备份SQL数据库"
   ClientHeight    =   4410
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6975
   Icon            =   "frmBackup.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4410
   ScaleWidth      =   6975
   StartUpPosition =   2  '屏幕中心
   Begin VB.TextBox lblFilePath 
      Appearance      =   0  'Flat
      BackColor       =   &H8000000F&
      Height          =   315
      Left            =   2400
      Locked          =   -1  'True
      TabIndex        =   6
      Top             =   1770
      Width           =   4215
   End
   Begin VB.ListBox lstDatabase 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   3420
      Left            =   300
      TabIndex        =   3
      Top             =   570
      Width           =   1965
   End
   Begin VB.CommandButton cmdFilePath 
      Caption         =   "浏览"
      Height          =   345
      Left            =   5100
      TabIndex        =   2
      Top             =   1200
      Width           =   1305
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "退出"
      Height          =   345
      Left            =   4620
      TabIndex        =   1
      Top             =   3330
      Width           =   1305
   End
   Begin VB.CommandButton cmdBackup 
      Caption         =   "备份"
      Height          =   345
      Left            =   3150
      TabIndex        =   0
      Top             =   3330
      Width           =   1305
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "选择要备份的数据库："
      Height          =   180
      Index           =   0
      Left            =   360
      TabIndex        =   5
      Top             =   270
      Width           =   1800
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "选择备份路径："
      Height          =   180
      Index           =   1
      Left            =   2490
      TabIndex        =   4
      Top             =   1320
      Width           =   1260
   End
End
Attribute VB_Name = "frmBackup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lparam As Long
    iImage As Long
End Type

Const BIF_RETURNONLYFSDIRS = &H1
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long





Private Sub cmdBackup_Click()
    On Error GoTo err
    
    If Trim(lstDatabase.Text) = "" Then
        MsgBox "请选择要备份的数据库"
        Exit Sub
    End If
    If Trim(lblFilePath) = "" Then
        MsgBox "请选择备份路径"
        Exit Sub
    End If
    
    
    Screen.MousePointer = vbHourglass
    
    If BackUpDataBase(Trim(lblFilePath), Trim(lstDatabase.Text)) Then
        MsgBox "数据库已经成功备份"
    End If
    Screen.MousePointer = vbDefault
    
    Exit Sub
err:
    Screen.MousePointer = vbDefault
    MsgBox err.Description
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdFilePath_Click()
    On Error GoTo Err_ChangPath
    
    Dim bi As BROWSEINFO
    Dim r As Long
    Dim pidl As Long
    Dim Path As String
    Dim pos As Integer
    Dim strTempPath As String
    strTempPath = lblFilePath
    '句柄
    bi.hOwner = Me.hWnd
    '展开根目录
    bi.pidlRoot = 0&
    
    '规定只能选择文件夹，其他无效
        '列表框标题
    bi.lpszTitle = "请选择备份文件路径："
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    '调用API函数显示列表框
    
    pidl = SHBrowseForFolder(bi)
    
    '利用API函数获取返回的路径
    
    Path = Space$(512)
    
    r = SHGetPathFromIDList(ByVal pidl&, ByVal Path)
    If r Then
        pos = InStr(Path, Chr$(0))
        lblFilePath = Left(Path, pos - 1)

    Else:
        lblFilePath = strTempPath
    End If
    
    Exit Sub
Err_ChangPath:
    MsgBox err.Description
End Sub

Private Sub Form_Load()
    AddList
    

End Sub


'添加表
Public Sub AddList()
    On Error GoTo err

    lstDatabase.Clear
    
    If rs.State <> 0 Then rs.Close
    rs.Open "Select name from sysdatabases where name<>'master' and name<>'tempdb' and name<>'model' and name<>'msdb'"
    While (Not rs.EOF)
        lstDatabase.AddItem rs("name") & ""
        rs.MoveNext
    Wend
    
    Exit Sub
err:
    MsgBox err.Description
End Sub



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