module1.bas

学生宿舍管理系统vb源码

Attribute VB_Name = "Module1"
Private Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function sGetComputerName() As String
  Dim sBuffer As String
  Dim lBufSize As Long
  Dim lStatus As Long

  lBufSize = 255
  sBuffer = String$(lBufSize, " ")
  lStatus = GetComputerName(sBuffer, lBufSize)
  sGetComputerName = ""
  If lStatus <> 0 Then
     sGetComputerName = Left(sBuffer, lBufSize)
  End If

End Function


'*************************************************************************
'**模 块 名：fBackupDatabase_a
'**描 述：备份数据库,返回出错信息,正常恢复,返回""
'**调 用：fBackupDatabase_a "备份文件名","数据库名"
'**参数说明：
'** sBackUpfileName 恢复后的数据库存放目录
'** sDataBaseName 备份的数据名
'** sIsAddBackup 是否追加到备份文件中
'**说 明：引用Microsoft ActiveX Data Objects 2.x Library
'**创 建 人：
'**日 期：2003年12月09日
'*************************************************************************
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$
    
    On Error GoTo lbErr
    
    '创建对象
    Set iDb = New ADODB.Connection
    
    '连接数据库服务器,根据你的情况修改连接字符串
    iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=" & sGetComputerName()
    iDb.Open iConcStr
    
    '生成数据库备份语句
    iSql = "backup database [" & sDataBaseName & "]" & vbCrLf & _
    "to disk='" & sBackUpfileName & "'" & vbCrLf & _
    "with description='" & "Grace-backup at:" & Date & "(" & Time & ")'" & vbCrLf & _
    IIf(sIsAddBackup, "", ",init")
    
    iDb.Execute iSql
    GoTo lbExit
    
lbErr:
    iReturn = Error
lbExit:
    fBackupDatabase_a = iReturn
End Function



'*************************************************************************
'**模 块 名：frestoredatabase_a
'**描 述：恢复数据库,返回出错信息,正常恢复,返回""
'**调 用：frestoredatabase_a "备份文件名","数据库名"
'**参数说明：
'** sDataBasePath 恢复后的数据库存放目录
'** sBackupNumber 是从那个备份号恢复
'** sReplaceExist 指定是否覆盖已经存在的数据
'**说 明：引用Microsoft ActiveX Data Objects 2.x Library
'**创 建 人：
'**日 期：2003年12月09日
'*************************************************************************
Public 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
    
    '连接数据库服务器,根据你的情况修改连接字符串
    iConcStr = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=" & sGetComputerName()
    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