moddatabase.bas

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

    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdStoredProc
        .CommandText = "sp_addumpdevice"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("devtype", adVarChar, adParamInput, 20, "disk")
        .Parameters.Append .CreateParameter("logicalname", adVarChar, adParamInput, 64, strDevice)
        .Parameters.Append .CreateParameter("physicalname", adVarChar, adParamInput, 260, strFileName)
        .Execute
        If CLng(.Parameters("RETURN_VALUE").Value) <> 0 Then GoTo ERROR_EXIT
    End With
    
    CreateDBDevice = strDevice
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    If Err.Number <> 0 Then
        MsgBox Error(Err.Number), vbOKOnly Or vbExclamation, "数据库错误"
        If Err.Number = -2147217900 Then
            If vbYes = MsgBox("必须删除该设备才能进行后续操作，是否删除该设备？", vbYesNo, "操作提示") Then
                Dim strDev As String
                strDev = GetDBDevice(conn, strFileName)
                If strDev <> "" Then
                    DropDBDevice conn, strDev
                    GoTo RESTART
                Else
                    MsgBox "删除该设备失败", vbOKOnly Or vbExclamation, "数据库错误"
                End If
            End If
        End If
        Err.Clear
    End If
    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
    
    Set cmd = Nothing
    CreateDBDevice = ""
End Function

'***********************************************
' 在数据库中获得设备名称
' 参数：    strPhysicalName 设备的物理名称
' 返回值：如果成功则返回设备名，否则返回空字符串
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_addumpdevice 要求操作员必须是 diskadman
'           sp_dropdevice   要求操作员必须是 sysadman
Private Function GetDBDevice(ByVal conn As ADODB.Connection, ByVal strPhysicalName As String) As String
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim strDevice As String
    
    strDevice = ""
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdText
        .CommandText = "sp_helpdevice"
        Set rs = .Execute
        While Not rs.EOF
            If Trim(rs!physical_name) = Trim(strPhysicalName) Then strDevice = Trim(rs!device_name)
            rs.MoveNext
        Wend
    End With
    If strDevice = "" Then GoTo ERROR_EXIT
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetDBDevice = strDevice
    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
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetDBDevice = ""
End Function

'***********************************************
' 在数据库中删除设备
' 参数：    strDeviceName 设备名
' 数据库权限：调用 SQL 系统存储过程时需要一定权限。
'           sp_dropdevice   要求操作员必须是 sysadman
Private Sub DropDBDevice(ByVal conn As ADODB.Connection, _
                         ByVal strDeviceName As String, _
                         Optional ByVal fDelfile As Boolean = False)
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    
    If strDeviceName = "" Then Exit Sub
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdText
        .CommandText = "sp_dropdevice " & strDeviceName
        If fDelfile Then .CommandText = .CommandText & " , delfile "
        .Execute
    End With
    
    Set cmd = Nothing
    Exit Sub
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
    
    Set cmd = Nothing
End Sub

'***********************************************
' 初始化可供导入导出的数据库表信息
' 窗体 dlgDataExport 和 dlgDataImport 要用到此函数
Public Function InitBKTableInfo() As Boolean
    On Error GoTo ERROR_EXIT
    Dim strTables() As String
    Dim strTemp() As String
    Dim i  As Long
    
    ReDim g_BKTableSet(UBound(strTables))
    For i = LBound(strTables) To UBound(strTables)
        strTemp = Split(strTables(i), vbTab)
        g_BKTableSet(i).strTableDesc = Trim(strTemp(0))
        g_BKTableSet(i).strTableName = Trim(strTemp(1))
    Next
    InitBKTableInfo = 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
    
    InitBKTableInfo = False
End Function

'***********************************************
' 获得数据库当前连接的用户数目
' 使用 SQL 的 sp_who 存储过程
Private Function GetDBConnectionUserNum(ByVal dbConn As ADODB.Connection) As Long
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    Dim nUser As Long
    Dim strUserNames As String
    
    nUser = 0
    strUserNames = ""
    With cmd
        Set .ActiveConnection = dbConn
        .CommandType = adCmdText
        .CommandText = "SP_WHO --'ACTIVE'"
        Set rs = .Execute
        While Not rs.EOF
            If Trim(rs!dbname) = g_MyUserDB.strUserDatabase Then
                If InStr(strUserNames, Trim(rs!loginame)) <= 0 Then
                    nUser = nUser + 1
                    strUserNames = strUserNames & Trim(rs!loginame) & vbTab
                End If
            End If
            rs.MoveNext
        Wend
    End With
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    
    GetDBConnectionUserNum = nUser
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetDBConnectionUserNum"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetDBConnectionUserNum = -1
End Function

'*********************************
' 获得备份文件中 MDF 和 LDF 文件的名称
Private Function GetMDFAndLDFFile(ByVal strDevice As String, ByVal conn As ADODB.Connection) As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim rs As New ADODB.Recordset
    
    m_strMDFFile = ""
    m_strLDFFile = ""
    With cmd
        Set .ActiveConnection = conn
        .CommandType = adCmdText
        .CommandText = "RESTORE FILELISTONLY FROM " & strDevice
        Set rs = .Execute
        While Not rs.EOF
            If Trim(rs!Type) = "D" Then m_strMDFFile = Trim(rs!LogicalName)
            If Trim(rs!Type) = "L" Then m_strLDFFile = Trim(rs!LogicalName)
            rs.MoveNext
        Wend
    End With
    
    If m_strMDFFile = "" Or m_strLDFFile = "" Then GoTo ERROR_EXIT
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetMDFAndLDFFile = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetDBConnectionUserNum"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Set cmd = Nothing
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    GetMDFAndLDFFile = False
End Function