moddatabase.bas

排队分诊管理系统源代码！该代码使用VB6开发环境

    Set clsReg = Nothing
    FixDBForBackup = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "FixDBForBackup"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
ERROR_EXIT1:
    Set cmd = Nothing
    Set clsReg = Nothing
    FixDBForBackup = False
End Function

'*********************************
' 恢复数据库
' 参数      ：
'           strFileName     备份文件名
' 说明      ：数据库恢复操作必须建立排他的数据库连接。否则恢复无法执行。
' 数据库操作：执行类似以下的 3 句 SQL 语句
'           EXEC sp_addumpdevice 'disk', 'CYCRM_BACK',     'C:\MSSQL7\BACKUP\BACKUP.dat'
'           RESTORE DATABASE CYCRM TO CYCRM_BACK -- WITH STATS = 1
'           EXEC sp_dropdevice 'CYCRM_BACK'  , 'DELFILE'
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Public Function RestoreDataBase(ByVal strFileName As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    Dim conn As New ADODB.Connection
    Dim fDeviceAdded As Boolean
    Dim nConnNum As Long
    Dim fFlag As Boolean
    Dim strSQLSysPath As String
    strSQLSysPath = GetSQLServerSysPath
    
    If Right(strSQLSysPath, 1) <> "\" Then strSQLSysPath = strSQLSysPath & "\"
    fFlag = False
    nConnNum = GetDBConnectionUserNum(dbMyDB)
    If nConnNum < 0 Then
        GoTo ERROR_EXIT
    ElseIf nConnNum > 1 Then
        MsgBox "系统发现其他用户正在使用本数据库，因此无法进行数据库恢复操作！" & vbCrLf & _
                "请确认没有其他用户连接到本数据库后，再进行数据库恢复操作。", _
                vbOKOnly Or vbExclamation, "恢复数据库操作失败"
        GoTo ERROR_EXIT1
    End If
    CloseDB
    fFlag = True
    conn.ConnectionString = _
        "Provider=SQLOLEDB.1;Persist Security Info=False;" + _
        "User ID=" + g_MyUserDB.strUserName + _
        ";Password=" + g_MyUserDB.strUserPassword + _
        ";Initial Catalog=master" + _
        ";Data Source=" + g_MyUserDB.strUserDatasource
    conn.Open
    If conn.State <> adStateOpen Then GoTo ERROR_EXIT
    
    nConnNum = GetDBConnectionUserNum(conn)
    If nConnNum > 0 Then
        MsgBox "系统发现其他用户正在使用本数据库，因此无法进行数据库恢复操作！" & vbCrLf & _
                "请确认没有其他用户连接到本数据库后，再进行数据库恢复操作。", _
                vbOKOnly Or vbExclamation, "恢复数据库操作失败"
        GoTo ERROR_EXIT1
    End If
    strDevice = CreateDBDevice(conn, strFileName, "CYCRM_BACKUP_")
    If strDevice = "" Then GoTo ERROR_EXIT1
    If Not GetMDFAndLDFFile(strDevice, conn) Then GoTo ERROR_EXIT1
    With cmd
        .ActiveConnection = conn
        '.CommandText = " RESTORE DATABASE " & g_MyUserDB.strUserDatabase & _
                        " FROM " & strDevice & " WITH RECOVERY "
        .CommandText = " RESTORE DATABASE " & g_MyUserDB.strUserDatabase & _
                        " FROM " & strDevice & " WITH " & _
                        " MOVE '" & m_strMDFFile & "' TO '" & strSQLSysPath & g_MyUserDB.strUserDatabase & ".mdf' , " & _
                        " MOVE '" & m_strLDFFile & "' TO '" & strSQLSysPath & g_MyUserDB.strUserDatabase & ".ldf'" & _
                        " , REPLACE , RESTART"
        Debug.Print .CommandText
        .Execute
    End With
    DropDBDevice conn, strDevice
        
    Set cmd = Nothing
    
    If fFlag Then Set dbMyDB = New ADODB.Connection
    If dbMyDB.State <> adStateOpen Then OpenDB
    If conn.State = adStateOpen Then conn.Close
    Set conn = Nothing
    RestoreDataBase = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "RestoreDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number = -2147217900 Then
        MsgBox "系统发现其他用户正在使用本数据库，因此无法进行数据库恢复操作！" & vbCrLf & _
                "请确认没有其他用户连接到本数据库后，再进行数据库恢复操作。", _
                vbOKOnly Or vbExclamation, "恢复数据库操作失败"
    End If
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
ERROR_EXIT1:
    Set cmd = Nothing
    If fFlag Then Set dbMyDB = New ADODB.Connection
    If dbMyDB.State <> adStateOpen Then OpenDB
    If conn.State = adStateOpen Then
        DropDBDevice conn, strDevice
        conn.Close
    End If
    Set conn = Nothing
    RestoreDataBase = False
End Function

'*********************************
' 备份数据库
' 参数      ：
'           strFileName     备份文件名
'           fFull           是否完全备份 true 表示完全备份， false 表示增量备份
' 数据库操作：执行类似以下的 4 句 SQL 语句
'           EXEC sp_addumpdevice 'disk', 'CYCRM_BACK',     'C:\MSSQL7\BACKUP\BACKUP.dat'
'           BACKUP DATABASE CYCRM TO CYCRM_BACK -- WITH STATS = 1
'           EXEC sp_dropdevice 'CYCRM_BACK'  , 'DELFILE'
'           调用 SPEX_DBBC_BACKUP 增加一条记录
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Public Function BackupDataBase(ByVal strFileName As String, ByVal fFull As Boolean) As Boolean
    On Error GoTo ERROR_EXIT
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    Dim fDeviceAdded As Boolean
    strDevice = CreateDBDevice(dbMyDB, strFileName, "CYCRM_BACKUP_")
    
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdText
        .CommandText = " BACKUP DATABASE " & g_MyUserDB.strUserDatabase & _
                        " TO " & strDevice & " WITH INIT "
        If Not fFull Then .CommandText = .CommandText & " WITH DIFFERENTIAL "
        .Execute
    End With
    Set cmd = Nothing
    Set cmd = New ADODB.Command
    With cmd
        '调用 SPEX_DBBC_BACKUP 增加一条记录
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdStoredProc
        .Parameters.Refresh
        .CommandText = "SPEX_DBBC_BACKUP"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("bc_filename", adVarChar, adParamInput, 255, strFileName)
        .Parameters.Append .CreateParameter("bc_SrcdbName", adVarChar, adParamInput, 128, g_MyUserDB.strUserDatabase)
        .Parameters.Append .CreateParameter("bc_full", adInteger, adParamInput, , IIf(fFull, 0, 1))
        .Parameters.Append .CreateParameter("bc_UserName", adVarChar, adParamInput, 255, m_strOld)
        .Execute
        If .Parameters("RETURN_VALUE").Value <> 0 Then
            m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
            m_tagErrInfo.strErrFile = "modDatabase"
            m_tagErrInfo.strErrFunc = "BackupDataBase"
            m_tagErrInfo.nErrNum = -1
            m_tagErrInfo.strErrDesc = "调用存储过程 SPEX_DBBC_BACKUP 失败，返回值为" & .Parameters("RETURN_VALUE").Value
            If Err.Number <> 0 Then Err.Clear
            modErrorInfo.WriteErrLog m_tagErrInfo
            GoTo ERROR_EXIT1
        End If
    End With
    
    DropDBDevice dbMyDB, strDevice
    Set cmd = Nothing
    BackupDataBase = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "BackupDataBase"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
ERROR_EXIT1:
    DropDBDevice dbMyDB, strDevice
    Set cmd = Nothing
    BackupDataBase = False
End Function

'***********************************************
' 删除数据库备份文件操作
Public Sub DeleteBackupFile(ByVal strFileName As String)
    On Error Resume Next
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    
    If Trim(strFileName) = "" Then Exit Sub
    strDevice = CreateDBDevice(dbMyDB, strFileName, "CYCRM_DELETE_")
    DropDBDevice dbMyDB, strDevice, True
    '删除数据库记录
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdStoredProc
        .CommandText = "SPEX_DBBC_DELETE_FILE"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("bc_filename", adVarChar, adParamInput, 255, Trim(strFileName))
        .Execute
        If CLng(.Parameters("RETURN_VALUE").Value) <> 0 Then
            m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
            m_tagErrInfo.strErrFile = "modDatabase"
            m_tagErrInfo.strErrFunc = "DeleteBackupFile"
            m_tagErrInfo.nErrNum = -1
            m_tagErrInfo.strErrDesc = "调用存储过程 SPEX_DBBC_DELETE_FILE 出错，返回值 " _
                & .Parameters("RETURN_VALUE").Value
            If Err.Number <> 0 Then Err.Clear
            modErrorInfo.WriteErrLog m_tagErrInfo
        End If
        
    End With
    Set cmd = Nothing
End Sub

'***********************************************
' 在数据库中创建设备
' 参数：    strFileName     文件路径
'           strPrefix       设备名的前导字符串
' 返回值：如果成功则返回设备名，否则返回空字符串
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Private Function CreateDBDevice(ByVal conn As ADODB.Connection, _
                                ByVal strFileName As String, _
                                Optional ByVal strPrefix As String = "") As String
    On Error GoTo ERROR_EXIT
    Dim strDevice As String
    Dim cmd As New ADODB.Command
    
RESTART:
    Randomize Second(Time)
    strDevice = strPrefix & CStr(CLng(Rnd * 10000000))