添加一个commondialog控件,名称为dlg,我要备份和恢复的数据库名字为hy,执行备份的语句就是 sql = "BACKUP DATABASE hy TO disk='" & dlg.FileName & "'" Cn.Execute (sql) 恢复的语句: sql = "RESTORE DATABASE hy FROM disk='" & dlg.FileName & "' WITH replace" Cn.Execute (sql)1、备份数据库代码 Dim Ret As String
'备份数据库hy Ret = MsgBox("备份主要数据库--hy ?", vbOKCancel + vbInformation, "提示") If Ret = vbOK Then
dlg.ShowSave '如果dlg控件点击取消 If dlg.FileName = "" Then Exit Sub End If If Dir(dlg.FileName) <> "" Then If MsgBox("文件" & dlg.FileName & "已存在!要替换吗?", vbYesNo, "提示") = vbYes Then Kill dlg.FileName Else Exit Sub End If End If '执行备份 connectString="Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Password=;Data Source=hh-zhou;Initial Catalog=master" MousePointer = 11 Dim Cn As New ADODB.Connection If Cn.State = adStateOpen Then Cn.Close Cn.ConnectionTimeout = 10
Cn.Open ConnectString
sql = "BACKUP DATABASE hy TO disk='" & dlg.FileName & "'" Cn.Execute (sql)
If Trim(Text1.Text) = "" Then MsgBox "请输入备份文件名", vbInformation + vbOKOnly, "提示" Text1.SetFocus Exit Sub End If
If Dir(Text1.Text) <> "" Then '文件已存在 If MsgBox("此备份文件已存在,你确定要覆盖吗?", vbQuestion + vbOKCancel, "警告") <> vbOK Then '取消操作 Text1.SetFocus Exit Sub End If End If Screen.MousePointer = 11 Call fBackupDatabase_a(Trim(Text1.Text), con, False)'恢复 Dim i As Integer Dim pwsstr As String Const con = "tjzh_ck" '数据库名称 If Trim(Text1.Text) = "" Then MsgBox "请输入还原所需的文件名", vbInformation + vbOKOnly, "提示" Text1.SetFocus Exit Sub End If
If Dir(Text1.Text) = "" Then '文件不存在 MsgBox "恢复文件不存在,不能恢复", vbInformation + vbOKOnly, "警告" Text1.SetFocus Exit Sub End If
pwsstr = InputBox("请输入操作口令。", "提示") If pwsstr <> UserPassword Then MsgBox "口令错误", vbExclamation + vbOKOnly, "提示" Exit Sub End If
If MsgBox("数据恢复会覆盖已有数据并且不能恢复,你确定要恢复数据库吗?", vbExclamation + vbOKOnly, "警告") <> vbOK Then Text1.SetFocus Exit Sub End If Screen.MousePointer = 11 Call fRestoreDatabase_a(Trim(Text1.Text), con, "", 1, False) End '恢复完后,必须重启计算机 Public Function fBackupDatabase_a(ByVal sBackUpfileName$, ByVal sDataBaseName$, Optional ByVal sIsAddBackup As Boolean = False) As String Dim iDb As ADODB.Connection Dim iConcStr$, iSql$, iReturn$, tjzh$ On Error GoTo lbErr'创建对象 Set iDb = New ADODB.ConnectioniDb.CommandTimeout = 900
'连接数据库服务器,根据你的情况修改连接字符串 iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=htjs5" 'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=tjzh;Data Source=htjs5;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=HTJS5;Use Encryption for Data=False;Tag with column collation when possible=False iDb.Open iConcStr '生成数据库备份语句 iSql = "backup database [" & sDataBaseName & "]" & vbCrLf & _ "to disk='" & sBackUpfileName & "'" & vbCrLf & _ "with description='" & "天津昭和-backup at:" & Date & "(" & time & ")'" & vbCrLf & _ IIf(sIsAddBackup, "", ",init") iDb.Execute iSql GoTo lbExit lbErr: iReturn = Error lbExit: fBackupDatabase_a = iReturn End FunctionPublic Function fRestoreDatabase_a(ByVal sBackUpfileName$, ByVal sDataBaseName$, Optional ByVal sDataBasePath$ = "", Optional ByVal sBackupNumber& = 1, Optional ByVal sReplaceExist As Boolean = False) As String Dim iDb As ADODB.Connection, iRe As ADODB.Recordset Dim iConcStr$, iSql$, iReturn$, iI& On Error GoTo lbErr '创建对象 Set iDb = New ADODB.Connection Set iRe = New ADODB.Recordset iDb.CommandTimeout = 900 '连接数据库服务器,根据你的情况修改连接字符串 iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=htjs5" iDb.Open iConcStr '得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录 If sDataBasePath = "" Then iSql = "select filename from master..sysfiles" iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly iSql = iRe(0) iRe.Close sDataBasePath = Left(iSql, InStrRev(iSql, "\")) End If '检查数据库是否存在 'If sReplaceExist = False Then ' iSql = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'" ' iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly ' If iRe.EOF = False Then ' iReturn = "数据库已经存在!" ' iRe.Close ' GoTo lbExit ' End If 'iRe.Close 'End If '关闭用户进程,防止其它用户正在使用数据库,导致数据恢复失败 iSql = "select spid from master..sysprocesses where dbid=db_id('" & sDataBaseName & "')" iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly While iRe.EOF = False iSql = "kill " & iRe(0) iDb.Execute iSql iRe.MoveNext Wend iRe.Close '获取数据库恢复信息 iSql = "restore filelistonly from disk='" & sBackUpfileName & "'" & vbCrLf & _ "with file=" & sBackupNumber iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly '生成数据库恢复语句 iSql = "restore database [" & sDataBaseName & "]" & vbCrLf & _ "from disk='" & sBackUpfileName & "'" & vbCrLf & _ "with file=" & sBackupNumber & vbCrLf With iRe
While Not .EOF iReturn = iRe("PhysicalName") iI = InStrRev(iReturn, ".") iReturn = IIf(iI = 0, "", Mid(iReturn, iI)) & "'" iSql = iSql & ",move '" & iRe("LogicalName") & _ "' to '" & sDataBasePath & sDataBaseName & iReturn & vbCrLf .MoveNext Wend .Close End With iSql = iSql & IIf(sReplaceExist, ",replace", "") iDb.Execute iSql iReturn = ""
GoTo lbExit lbErr: iReturn = Error lbExit: fRestoreDatabase_a = iReturn End Function
我的做法是这样的。希望对大家有所帮助。 定义一个函数。 sBackUpfileName 恢复后的数据库存放目录 sDataBaseName 备份的数据名 sIsAddBackup 是否追加到备份文件中 Public Function fBackupDatabase_a(ByVal sBackUpfileName$ _ , ByVal sDataBaseName$ _ , Optional ByVal sIsAddBackup As Boolean = False _ ) As String
Dim SQLCn As ADODB.Connection Dim iConcStr$, iSql$, iReturn$
lbErr: iReturn = Error lbExit: fBackupDatabase_a = iReturn End Function 前台调用。 在form1的窗体上放个Command控件。 private sub Command1_click() dim fileName as string Dim str As String Dim fileName As String fileName = CStr(Now) fileName = Replace(fileName, " ", "_") fileName = Replace(fileName, ":", "_") fileName = App.path & "\backup\" & fileName & ".bak" str = fBackupDatabase_a(fileName, "hszy", False)
If str = "" Then If MsgBox("备份成功!", vbOKOnly + vbInformation, "数据备份") = vbOK Then Unload Me End If Else If MsgBox(str, vbOKOnly + vbInformation, "数据备份") = vbOK Then Unload Me End If End If end sub ======================================================== 以下是数据库恢复 同样定义一个函数 sDataBasePath 恢复后的数据库存放目录 sBackupNumber 是从那个备份号恢复 sReplaceExist 指定是否覆盖已经存在的数据 sServerName 服务器名称sServerUser 用户名 sServerPswd 密码 Public Function fRestoreDatabase_a(ByVal sBackUpfileName As String _ , ByVal sDataBaseName As String _ , ByVal sServerName As String _ , ByVal sServerUser As String _ , ByVal sServerPswd As String _ , Optional ByVal sDataBasePath = "" _ , Optional ByVal sBackupNumber& = 1 _ , Optional ByVal sReplaceExist As Boolean = False _ ) As String
Dim iDb As ADODB.Connection, iRe As ADODB.Recordset Dim iConcStr, iSql, iReturn, iI
On Error GoTo lbErr
'创建对象 Set iDb = New ADODB.Connection Set iRe = New ADODB.Recordset
'得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录 If sDataBasePath = "" Then iSql = "select filename from master..sysfiles" iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly iSql = iRe(0) iRe.Close sDataBasePath = Left(iSql, InStrRev(iSql, "\")) End If
'检查数据库是否存在 If sReplaceExist = False Then iSql = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'" iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly If iRe.EOF = False Then iReturn = "数据库已经存在!" iRe.Close GoTo lbExit End If iRe.Close End If
lbErr: iReturn = Error lbExit: fRestoreDatabase_a = iReturn End Function 前台调用 在form1 的窗体上放个Command1控件。 private sub Command1_click() filePath = App.path & "\Restore"
str = fRestoreDatabase_a(Trim(Text1.Text), "hszy", serverName, serverUser, serverPwd, filePath, , True) If str = "" Then If MsgBox("数据恢复成功!", vbOKOnly + vbInformation, "数据恢复") = vbOK Then openSQLCn serverName, serverUser, serverPwd ‘打开连接的函数 Unload Me End If Else If MsgBox(str, vbOKOnly + vbInformation, "数据恢复") = vbOK Then Unload Me End If End If end sub 试试看。
备份可以实现,恢复就不行了,我恢复的代码如下:请各位帮我找找错误!谢谢 Private Sub RestoreDB_Click()Dim rRet, rStr, filePath As String Const dbName = "Quality" filePath = App.Path & "\BackUp\Restore" rRet = MsgBox("数据恢复会覆盖已有数据并且不能恢复,你确定要恢复数据库吗?", vbExclamation + vbOKCancel, "警告") If rRet = vbOK Then Dlg.CancelError = False Dlg.Filter = "(*.bak)|*.bak" Dlg.ShowOpen '如果dlg控件点击取消 If Dlg.fileName = "" Then Exit Sub End If If Dir(Dlg.fileName) <> "" Then rStr = fRestoreDatabase_a(Dlg.fileName, dbName, filePath, , True) If rStr = "" Then MsgBox "数据恢复成功!", vbOKOnly + vbInformation, "数据恢复" 'opensqlcn serverName, serverUser, serverPwd Else MsgBox rStr, vbOKOnly + vbInformation, "数据恢复" End If End If End If End Sub ‘函数 Public Function fRestoreDatabase_a(ByVal sBackUpfileName As String, Optional ByVal sDataBasePath$ = "", Optional ByVal sBackupNumber& = 1, Optional ByVal sReplaceExist As Boolean = False) As String Dim resCN As ADODB.Connection Dim resRST As ADODB.Recordset Dim resConString$, resSQL$, iReturn$, iI& On Error GoTo lbErr '创建对象 Set resCN = New ADODB.Connection Set resRST = New ADODB.Recordset resCN.CommandTimeout = 900 '连接数据库服务器,根据情况修改连接字符串 resConString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=Quality;Data Source=(local)" resCN.Open resConString '得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录 If sDataBasePath = "" Then resSQL = "select filename from master..sysfiles" resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly resSQL = resRST(0) resRST.Close sDataBasePath = Left(resSQL, InStrRev(resSQL, "\")) End If '检查数据库是否存在 If sReplaceExist = False Then resSQL = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'" resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly If resRST.EOF = False Then iReturn = "数据库已经存在!" resRST.Close GoTo lbexit End If resRST.Close End If'关闭用户进程,防止其它用户正在使用数据库,导致数据恢复失败 resSQL = "select spid from master..sysprocesses where dbid=db_id('" & sDataBaseName & "')" resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly While resRST.EOF = False resSQL = "kill " & resRST(0) resCN.Execute resSQL resRST.MoveNext Wend resRST.Close '获取数据库恢复信息 resSQL = "restore filelistonly from disk='" & sBackUpfileName & "'" & vbCrLf & _ "with file=" & sBackupNumber resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly '生成数据库恢复语句 resSQL = "restor database [" & sDataBaseName & "]" & vbCrLf & "from disk='" & _ sBackUpfileName & "'" & vbCrLf & "with file" & sBackupNumber & vbCrLf With resRST While Not .EOF iReturn = resRST("PhysicalName") iI = InStrRev(iReturn, ".") iReturn = IIf(iI = 0, "", Mid(iReturn, iI)) & "'" resSQL = resSQL & ",move '" & resRST("LogicalName") & "'to'" & sDataBasePath & sDataBaseName & iReturn & vbCrLf .MoveNext Wend .Close End With resSQL = resSQL & IIf(sReplaceExist, ",replace", "") resCN.Execute resSQL iReturn = "" GoTo lbexit
lbErr: iReturn = Error lbexit: fRestoreDatabase_a = iReturn End Function
sql = "BACKUP DATABASE hy TO disk='" & dlg.FileName & "'"
Cn.Execute (sql)
恢复的语句:
sql = "RESTORE DATABASE hy FROM disk='" & dlg.FileName & "' WITH replace"
Cn.Execute (sql)1、备份数据库代码
Dim Ret As String
'备份数据库hy
Ret = MsgBox("备份主要数据库--hy ?", vbOKCancel + vbInformation, "提示")
If Ret = vbOK Then
dlg.CancelError = False
dlg.Filter = "(*.bak)|*.bak"
dlg.ShowSave
'如果dlg控件点击取消
If dlg.FileName = "" Then
Exit Sub
End If
If Dir(dlg.FileName) <> "" Then
If MsgBox("文件" & dlg.FileName & "已存在!要替换吗?", vbYesNo, "提示") = vbYes Then
Kill dlg.FileName
Else
Exit Sub
End If
End If
'执行备份 connectString="Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Password=;Data Source=hh-zhou;Initial Catalog=master"
MousePointer = 11
Dim Cn As New ADODB.Connection
If Cn.State = adStateOpen Then Cn.Close
Cn.ConnectionTimeout = 10
Cn.Open ConnectString
sql = "BACKUP DATABASE hy TO disk='" & dlg.FileName & "'"
Cn.Execute (sql)
Cn.Close
Set Cn = Nothing
MousePointer = 0
End If
我用的时ODBC连接的数据库!请各位指教!不胜感激!
Const con = "tjzh_ck" '数据库名称
If Trim(Text1.Text) = "" Then
MsgBox "请输入备份文件名", vbInformation + vbOKOnly, "提示"
Text1.SetFocus
Exit Sub
End If
If Dir(Text1.Text) <> "" Then '文件已存在
If MsgBox("此备份文件已存在,你确定要覆盖吗?", vbQuestion + vbOKCancel, "警告") <> vbOK Then '取消操作
Text1.SetFocus
Exit Sub
End If
End If
Screen.MousePointer = 11
Call fBackupDatabase_a(Trim(Text1.Text), con, False)'恢复
Dim i As Integer
Dim pwsstr As String
Const con = "tjzh_ck" '数据库名称
If Trim(Text1.Text) = "" Then
MsgBox "请输入还原所需的文件名", vbInformation + vbOKOnly, "提示"
Text1.SetFocus
Exit Sub
End If
If Dir(Text1.Text) = "" Then '文件不存在
MsgBox "恢复文件不存在,不能恢复", vbInformation + vbOKOnly, "警告"
Text1.SetFocus
Exit Sub
End If
pwsstr = InputBox("请输入操作口令。", "提示")
If pwsstr <> UserPassword Then
MsgBox "口令错误", vbExclamation + vbOKOnly, "提示"
Exit Sub
End If
If MsgBox("数据恢复会覆盖已有数据并且不能恢复,你确定要恢复数据库吗?", vbExclamation + vbOKOnly, "警告") <> vbOK Then
Text1.SetFocus
Exit Sub
End If
Screen.MousePointer = 11
Call fRestoreDatabase_a(Trim(Text1.Text), con, "", 1, False)
End
'恢复完后,必须重启计算机
Public Function fBackupDatabase_a(ByVal sBackUpfileName$, ByVal sDataBaseName$, Optional ByVal sIsAddBackup As Boolean = False) As String
Dim iDb As ADODB.Connection
Dim iConcStr$, iSql$, iReturn$, tjzh$
On Error GoTo lbErr'创建对象
Set iDb = New ADODB.ConnectioniDb.CommandTimeout = 900
'连接数据库服务器,根据你的情况修改连接字符串
iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=htjs5"
'Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=tjzh;Data Source=htjs5;Use Procedure for Prepare=1;Auto Translate=True;Packet Size=4096;Workstation ID=HTJS5;Use Encryption for Data=False;Tag with column collation when possible=False
iDb.Open iConcStr
'生成数据库备份语句
iSql = "backup database [" & sDataBaseName & "]" & vbCrLf & _
"to disk='" & sBackUpfileName & "'" & vbCrLf & _
"with description='" & "天津昭和-backup at:" & Date & "(" & time & ")'" & vbCrLf & _
IIf(sIsAddBackup, "", ",init")
iDb.Execute iSql
GoTo lbExit
lbErr:
iReturn = Error
lbExit:
fBackupDatabase_a = iReturn
End FunctionPublic Function fRestoreDatabase_a(ByVal sBackUpfileName$, ByVal sDataBaseName$, Optional ByVal sDataBasePath$ = "", Optional ByVal sBackupNumber& = 1, Optional ByVal sReplaceExist As Boolean = False) As String
Dim iDb As ADODB.Connection, iRe As ADODB.Recordset
Dim iConcStr$, iSql$, iReturn$, iI&
On Error GoTo lbErr
'创建对象
Set iDb = New ADODB.Connection
Set iRe = New ADODB.Recordset
iDb.CommandTimeout = 900
'连接数据库服务器,根据你的情况修改连接字符串
iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=htjs5"
iDb.Open iConcStr
'得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录
If sDataBasePath = "" Then
iSql = "select filename from master..sysfiles"
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
iSql = iRe(0)
iRe.Close
sDataBasePath = Left(iSql, InStrRev(iSql, "\"))
End If
'检查数据库是否存在
'If sReplaceExist = False Then
' iSql = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'"
' iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
' If iRe.EOF = False Then
' iReturn = "数据库已经存在!"
' iRe.Close
' GoTo lbExit
' End If
'iRe.Close
'End If
'关闭用户进程,防止其它用户正在使用数据库,导致数据恢复失败
iSql = "select spid from master..sysprocesses where dbid=db_id('" & sDataBaseName & "')"
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
While iRe.EOF = False
iSql = "kill " & iRe(0)
iDb.Execute iSql
iRe.MoveNext
Wend
iRe.Close
'获取数据库恢复信息
iSql = "restore filelistonly from disk='" & sBackUpfileName & "'" & vbCrLf & _
"with file=" & sBackupNumber
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
'生成数据库恢复语句
iSql = "restore database [" & sDataBaseName & "]" & vbCrLf & _
"from disk='" & sBackUpfileName & "'" & vbCrLf & _
"with file=" & sBackupNumber & vbCrLf
With iRe
While Not .EOF
iReturn = iRe("PhysicalName")
iI = InStrRev(iReturn, ".")
iReturn = IIf(iI = 0, "", Mid(iReturn, iI)) & "'"
iSql = iSql & ",move '" & iRe("LogicalName") & _
"' to '" & sDataBasePath & sDataBaseName & iReturn & vbCrLf
.MoveNext
Wend
.Close
End With
iSql = iSql & IIf(sReplaceExist, ",replace", "")
iDb.Execute iSql
iReturn = ""
GoTo lbExit
lbErr: iReturn = Error
lbExit: fRestoreDatabase_a = iReturn
End Function
定义一个函数。
sBackUpfileName 恢复后的数据库存放目录
sDataBaseName 备份的数据名
sIsAddBackup 是否追加到备份文件中
Public Function fBackupDatabase_a(ByVal sBackUpfileName$ _
, ByVal sDataBaseName$ _
, Optional ByVal sIsAddBackup As Boolean = False _
) As String
Dim SQLCn As ADODB.Connection
Dim iConcStr$, iSql$, iReturn$
On Error GoTo lbErr
'创建对象
'Set SQLCn = New ADODB.Connection
'连接数据库服务器,根据你的情况修改连接字符串
iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=hszy"
SQLCn.Open iConcStr
'生成数据库备份语句
iSql = "backup database [" & sDataBaseName & "]" & vbCrLf & _
"to disk='" & sBackUpfileName & "'" & vbCrLf & _
"with description='" & "zj-backup at:" & Date & "(" & Time & ")'" & vbCrLf & _
IIf(sIsAddBackup, "", ",init")
SQLCn.Execute iSql
GoTo lbExit
lbErr:
iReturn = Error
lbExit:
fBackupDatabase_a = iReturn
End Function
前台调用。
在form1的窗体上放个Command控件。
private sub Command1_click()
dim fileName as string Dim str As String
Dim fileName As String
fileName = CStr(Now)
fileName = Replace(fileName, " ", "_")
fileName = Replace(fileName, ":", "_")
fileName = App.path & "\backup\" & fileName & ".bak"
str = fBackupDatabase_a(fileName, "hszy", False)
If str = "" Then
If MsgBox("备份成功!", vbOKOnly + vbInformation, "数据备份") = vbOK Then
Unload Me
End If
Else
If MsgBox(str, vbOKOnly + vbInformation, "数据备份") = vbOK Then
Unload Me
End If
End If
end sub
========================================================
以下是数据库恢复
同样定义一个函数
sDataBasePath 恢复后的数据库存放目录
sBackupNumber 是从那个备份号恢复
sReplaceExist 指定是否覆盖已经存在的数据
sServerName 服务器名称sServerUser 用户名
sServerPswd 密码
Public Function fRestoreDatabase_a(ByVal sBackUpfileName As String _
, ByVal sDataBaseName As String _
, ByVal sServerName As String _
, ByVal sServerUser As String _
, ByVal sServerPswd As String _
, Optional ByVal sDataBasePath = "" _
, Optional ByVal sBackupNumber& = 1 _
, Optional ByVal sReplaceExist As Boolean = False _
) As String
Dim iDb As ADODB.Connection, iRe As ADODB.Recordset
Dim iConcStr, iSql, iReturn, iI
On Error GoTo lbErr
'创建对象
Set iDb = New ADODB.Connection
Set iRe = New ADODB.Recordset
'连接数据库服务器,根据你的情况修改连接字符串
iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=" & sServerName
iDb.Open iConcStr
'得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录
If sDataBasePath = "" Then
iSql = "select filename from master..sysfiles"
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
iSql = iRe(0)
iRe.Close
sDataBasePath = Left(iSql, InStrRev(iSql, "\"))
End If
'检查数据库是否存在
If sReplaceExist = False Then
iSql = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'"
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
If iRe.EOF = False Then
iReturn = "数据库已经存在!"
iRe.Close
GoTo lbExit
End If
iRe.Close
End If
'关闭用户进程,防止其它用户正在使用数据库,导致数据恢复失败
iSql = "select spid from master..sysprocesses where dbid=db_id('" & sDataBaseName & "')"
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
While iRe.EOF = False
iSql = "kill " & iRe(0)
iDb.Execute iSql
iRe.MoveNext
Wend
iRe.Close
'获取数据库恢复信息
iSql = "restore filelistonly from disk='" & sBackUpfileName & "'" & vbCrLf & _
"with file=" & sBackupNumber
iRe.Open iSql, iDb, adOpenKeyset, adLockReadOnly
'生成数据库恢复语句
iSql = "restore database [" & sDataBaseName & "]" & vbCrLf & _
"from disk='" & sBackUpfileName & "'" & vbCrLf & _
"with file=" & sBackupNumber & vbCrLf
With iRe
While Not .EOF
iReturn = iRe("PhysicalName")
iI = InStrRev(iReturn, ".")
iReturn = IIf(iI = 0, "", Mid(iReturn, iI)) & "'"
iSql = iSql & ",move '" & iRe("LogicalName") & _
"' to '" & sDataBasePath & sDataBaseName & iReturn & vbCrLf
.MoveNext
Wend
.Close
End With
iSql = iSql & IIf(sReplaceExist, ",replace", "")
iDb.Execute iSql
iReturn = ""
GoTo lbExit
lbErr:
iReturn = Error
lbExit:
fRestoreDatabase_a = iReturn
End Function
前台调用
在form1 的窗体上放个Command1控件。
private sub Command1_click()
filePath = App.path & "\Restore"
str = fRestoreDatabase_a(Trim(Text1.Text), "hszy", serverName, serverUser, serverPwd, filePath, , True) If str = "" Then
If MsgBox("数据恢复成功!", vbOKOnly + vbInformation, "数据恢复") = vbOK Then
openSQLCn serverName, serverUser, serverPwd ‘打开连接的函数
Unload Me
End If
Else
If MsgBox(str, vbOKOnly + vbInformation, "数据恢复") = vbOK Then
Unload Me
End If
End If
end sub
试试看。
Private Sub RestoreDB_Click()Dim rRet, rStr, filePath As String
Const dbName = "Quality"
filePath = App.Path & "\BackUp\Restore"
rRet = MsgBox("数据恢复会覆盖已有数据并且不能恢复,你确定要恢复数据库吗?", vbExclamation + vbOKCancel, "警告")
If rRet = vbOK Then
Dlg.CancelError = False
Dlg.Filter = "(*.bak)|*.bak"
Dlg.ShowOpen
'如果dlg控件点击取消
If Dlg.fileName = "" Then
Exit Sub
End If
If Dir(Dlg.fileName) <> "" Then
rStr = fRestoreDatabase_a(Dlg.fileName, dbName, filePath, , True)
If rStr = "" Then
MsgBox "数据恢复成功!", vbOKOnly + vbInformation, "数据恢复"
'opensqlcn serverName, serverUser, serverPwd
Else
MsgBox rStr, vbOKOnly + vbInformation, "数据恢复"
End If
End If
End If
End Sub
‘函数
Public Function fRestoreDatabase_a(ByVal sBackUpfileName As String, Optional ByVal sDataBasePath$ = "", Optional ByVal sBackupNumber& = 1, Optional ByVal sReplaceExist As Boolean = False) As String
Dim resCN As ADODB.Connection
Dim resRST As ADODB.Recordset
Dim resConString$, resSQL$, iReturn$, iI&
On Error GoTo lbErr
'创建对象
Set resCN = New ADODB.Connection
Set resRST = New ADODB.Recordset
resCN.CommandTimeout = 900
'连接数据库服务器,根据情况修改连接字符串
resConString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=Quality;Data Source=(local)"
resCN.Open resConString
'得到还原后的数据库存放目录,如果没有指定,存放到SQL SERVER的DATA目录
If sDataBasePath = "" Then
resSQL = "select filename from master..sysfiles"
resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly
resSQL = resRST(0)
resRST.Close
sDataBasePath = Left(resSQL, InStrRev(resSQL, "\"))
End If
'检查数据库是否存在
If sReplaceExist = False Then
resSQL = "select 1 from master..sysdatabases where name='" & sDataBaseName & "'"
resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly
If resRST.EOF = False Then
iReturn = "数据库已经存在!"
resRST.Close
GoTo lbexit
End If
resRST.Close
End If'关闭用户进程,防止其它用户正在使用数据库,导致数据恢复失败
resSQL = "select spid from master..sysprocesses where dbid=db_id('" & sDataBaseName & "')"
resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly
While resRST.EOF = False
resSQL = "kill " & resRST(0)
resCN.Execute resSQL
resRST.MoveNext
Wend
resRST.Close
'获取数据库恢复信息
resSQL = "restore filelistonly from disk='" & sBackUpfileName & "'" & vbCrLf & _
"with file=" & sBackupNumber
resRST.Open resSQL, resCN, adOpenKeyset, adLockReadOnly
'生成数据库恢复语句
resSQL = "restor database [" & sDataBaseName & "]" & vbCrLf & "from disk='" & _
sBackUpfileName & "'" & vbCrLf & "with file" & sBackupNumber & vbCrLf
With resRST
While Not .EOF
iReturn = resRST("PhysicalName")
iI = InStrRev(iReturn, ".")
iReturn = IIf(iI = 0, "", Mid(iReturn, iI)) & "'"
resSQL = resSQL & ",move '" & resRST("LogicalName") & "'to'" & sDataBasePath & sDataBaseName & iReturn & vbCrLf
.MoveNext
Wend
.Close
End With resSQL = resSQL & IIf(sReplaceExist, ",replace", "")
resCN.Execute resSQL
iReturn = ""
GoTo lbexit
lbErr:
iReturn = Error
lbexit:
fRestoreDatabase_a = iReturn
End Function