moddatabase.bas

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

Attribute VB_Name = "modDatabase"
'****************************************************************************************
' MODULE        : modDatabase
' DESCRIPTION   : 数据库模块
' CREATE        :  2001,10,26
' CODE          :  2001,10,26
' FUNCTION      : 实现数据库相关操作
' USAGE         :
' SUMMARY       :
'   一、变量、数据结构
'       1.公共变量、数据结构
'           (1)TYPE_TABLE_DESC_INFO                         数据库表和显示名关联结构
'           (2)g_BKTableSet() As TYPE_TABLE_DESC_INFO       可供导入导出的数据库表信息
'       2.私有变量、数据结构
'           (1)Const m_strTableDescList                     初始化 g_BKTableSet 用的常量
'           (2)m_tagErrInfo As TYPE_ERRORINFO               错误信息记录变量
'           (3)m_strMDFFile , m_strLDFFile                  备份文件中 MDF 和 LDF 文件的名称
'   二、函数或过程
'       1. 公共函数或过程
'           (1) 检查否存在空基础表
'               Public Function ExistEmptyBaseTable(ByVal strTableNamesSet As String) As Boolean
'           (2) 获得基本信息表对应的描述说明性文字
'               Public Function GetDescOfBaseTable(ByVal strTableName As String) As String
'           (3) 获得系统进行数据库连接时使用的用户名和密码
'               Public Function GetSysUserName() As String
'               Public Function GetSysPassword() As String
'           (4) 获得 SQL 数据库服务器系统安装目录路径
'               Public Function GetSQLServerSysPath() As String
'           (5) 判断数据库是否完整，是否可以执行备份操作
'               Public Function DBCanExecBackup() As Boolean
'           (6) 修复数据库，以进行数据库备份、恢复操作
'               Private Function FixDBForBackup() As Boolean
'           (7) 备份数据库
'               Public Function BackupDataBase(ByVal strFileName As String, ByVal fFull As String) As Boolean
'           (8) 恢复数据库
'               Public Function RestoreDataBase(ByVal strFileName As String) As Boolean
'           (9) 删除数据库备份文件操作
'               Public Sub DeleteBackupFile(ByVal strFileName As String)
'           (10)初始化可供导入导出的数据库表信息
'               Public Function InitBKTableInfo() As Boolean
'       2. 私有（内部）函数或过程
'           (1) 检查数据库中一个表是否为空
'               Private Function IsTableEmpty(ByVal strTableName As String) As Boolean
'           (2) 检查数据库中一个表是否存在
'               Private Function IsTableExist(ByVal strTableName As String) As Boolean
'           (3) 在数据库中创建设备
'               Private Function CreateDBDevice(ByVal conn As adodb.Connection, _
'                                ByVal strFileName As String, _
'                                Optional ByVal strPrefix As String = "") As String
'           (4) 在数据库中删除设备
'               Private Sub DropDBDevice(ByVal conn As adodb.Connection, _
'                                ByVal strDeviceName As String, _
'                                Optional ByVal fDelfile As Boolean = False)
'           (5) 获得数据库当前连接的用户数目
'               Private Function GetDBConnectionUserNum(ByVal dbConn As adodb.Connection) As Long
'           (6)获得备份文件中 MDF 和 LDF 文件的名称
'               Private Function GetMDFAndLDFFile(ByVal strDevice As String, ByVal conn As adodb.Connection) As Boolean
'*********************************************************************************************************************************
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''
' 备份文件中 MDF 和 LDF 文件的名称
Dim m_strMDFFile As String
Dim m_strLDFFile As String

'''''''''''''''''''''''''''''''''''''''''''''''''''
' 错误信息
Dim m_tagErrInfo As TYPE_ERRORINFO

''''''''''''''''''''''''''''''''''''''''''''''''''''
' 数据库表和显示名关联结构
Public Type TYPE_TABLE_DESC_INFO
    strTableDesc    As String       ' 表的描述性名称
    strTableName    As String       ' 表名
End Type

' 可供导入导出的数据库表信息
Public g_BKTableSet() As TYPE_TABLE_DESC_INFO

'**************************************************************
'获得系统进行数据库连接时使用的用户名和密码
'        strUserName = "C73#09M73@03W73_11X75$06"
'        strUserPassword = "SIdaiGAI503_LOUrong"
Public Function GetSysUserName() As String
    On Error GoTo ERROR_EXIT
    
    GetSysUserName = "sa"
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetSysUserName"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "获得基本信息表对应的描述说明性文字失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    GetSysUserName = ""
End Function

Public Function GetSysPassword() As String
    On Error GoTo ERROR_EXIT
    
    GetSysPassword = "NOVA"
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetSysPassword"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "获得基本信息表对应的描述说明性文字失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    GetSysPassword = ""
End Function

'***********************************************************************************************************
'   获得 SQL 数据库服务器系统安装目录路径
' 说明：从数据库表 T_DATABASE_BACKUP 中获得服务器系统安装目录
Public Function GetSQLServerSysPath() As String
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset
    Dim cmd As New ADODB.Command
    
    '查询数据库主表
    cmd.ActiveConnection = dbMyDB
    cmd.CommandText = " SELECT bc_filename FROM T_DATABASE_BACKUP WHERE bc_flag = 1 " _
            & " AND UPPER (bc_SrcdbName) = '" & GetSQLServerName & "'"
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    
    If rs.State <> adStateOpen Then GoTo ERROR_EXIT
    If rs.EOF Or rs.RecordCount <> 1 Then GoTo ERROR_EXIT
    GetSQLServerSysPath = Trim(rs!bc_filename)
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetSQLServerSysPath"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    GetSQLServerSysPath = ""
End Function

'*********************************
' 判断数据库是否完整，是否可以执行备份操作
Public Function DBCanExecBackup() As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim nRet As Long
    
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdStoredProc
        .CommandText = "SPEX_DBBC_CAN_EXEC_BACKUP"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Execute
        nRet = CLng(.Parameters("RETURN_VALUE").Value)
        If nRet <> 0 Then
            Select Case nRet
                Case 100
                    If Not FixDBForBackup Then GoTo ERROR_EXIT1
                Case Else
                    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
                    m_tagErrInfo.strErrFile = "dlgDatabaseBackup"
                    m_tagErrInfo.strErrFunc = "DBCanExecBackup"
                    m_tagErrInfo.nErrNum = -1
                    m_tagErrInfo.strErrDesc = "调用存储过程 SPEX_DBBC_CAN_EXEC_BACKUP 出错，返回值" & nRet
                    If Err.Number <> 0 Then Err.Clear
                    modErrorInfo.WriteErrLog m_tagErrInfo
                    GoTo ERROR_EXIT
            End Select
        End If
    End With
    
    
    Set cmd = Nothing
    DBCanExecBackup = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "DBCanExecBackup"
    m_tagErrInfo.nErrNum = Err.Number
    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
    DBCanExecBackup = False
End Function

'*********************************
' 修复数据库，以进行数据库备份、恢复操作
' 目前主要是从注册表中获得数据库备份目录路径，然后刷新表 T_DATABASE_BACKUP 中的备份路径
Public Function FixDBForBackup() As Boolean
    On Error GoTo ERROR_EXIT
    Dim clsReg As New clsRegistry
    Dim strServerInstallPath As String
    Dim strRegRoot As String
    Dim FileSystems
    Dim cmd As New ADODB.Command
    
    If Not RunningOnSQLServer Then GoTo ERROR_EXIT1  ' 如果不在服务器上运行，则无法修复
    
    strRegRoot = g_strREG_SERVER_KEY
    If Not clsReg.CreateKey(eHKEY_LOCAL_MACHINE, strRegRoot) Then GoTo ERROR_EXIT1
    strServerInstallPath = CStr(clsReg.GetValue(eHKEY_LOCAL_MACHINE, strRegRoot, "Path"))
    strServerInstallPath = RemoveNullChar(strServerInstallPath)
    AddDirSep strServerInstallPath
    
    Set FileSystems = CreateObject("Scripting.FileSystemObject")
    If FileSystems.FolderExists(strServerInstallPath) Then
        If Not FileSystems.FolderExists(strServerInstallPath & "BACKUP") Then _
                FileSystems.CreateFolder (strServerInstallPath & "BACKUP")
        strServerInstallPath = strServerInstallPath & "BACKUP"
    Else
        strRegRoot = g_strREG_MSSQL_SETUP_KEY
        strServerInstallPath = CStr(clsReg.GetValue(eHKEY_LOCAL_MACHINE, strRegRoot, "SQLDataRoot"))
        strServerInstallPath = RemoveNullChar(strServerInstallPath)
        AddDirSep strServerInstallPath
        If Not FileSystems.FolderExists(strServerInstallPath & "BACKUP") Then GoTo ERROR_EXIT1
        strServerInstallPath = strServerInstallPath & "BACKUP"
    End If
    With cmd
        Set .ActiveConnection = dbMyDB
        .CommandType = adCmdText
        .CommandText = "INSERT T_DATABASE_BACKUP ( bc_filename , bc_SrcdbName , bc_BackupTime , bc_UserName , bc_flag ) " _
                & " VALUES ( '" & strServerInstallPath & "', '" & GetCurComputerName & "', GETDATE() , " & " 'ADMIN', '1')"
        .Execute
    End With

    Set cmd = Nothing