moddatabase.bas

ERP管理系统源代码erp 管理系统源代码

'            strDesc = "付款方式" & vbTab & "订单付款的方式，如现金、支票、商业汇票等。" & vbTab & "Payments"
'        Case "ProductStyles"
'            strDesc = "产品类型" & vbTab & "产品所属类型，如家电，家具等。" & vbTab & "ProductStyles"
'        Case "ProductSubStyles"
'            strDesc = "产品子类" & vbTab & "产品所属的子类型，如家电中的电视、洗衣机等。" & vbTab & "ProductSubStyles"
'        Case "SupplyClass"
'            strDesc = "供应商级别" & vbTab & "供应商的不同贡献度定义，如一星级、二星级等。" & vbTab & "SupplyClass"
'        Case "SupplyTypes"
'            strDesc = "供应商类型" & vbTab & "供应商性质定义，如批发商、零售商，生产商等。" & vbTab & "SupplyTypes"
'        Case "Territories"
'            strDesc = "地区资料" & vbTab & "客户、供应商所属地区，如华东，华北等。" & vbTab & "Territories"
'        Case "WithdrawDeals"
'            strDesc = "退货处理方式"
'        Case "Employees"
'            strDesc = "员工资料" & vbTab & "输入使用本系统员工的基本信息。" & vbTab & "Employees"
'        Case "Products"
'            strDesc = "产品资料" & vbTab & "输入使用本系统的相关产品信息。" & vbTab & "Products"
'        Case "Customers"
'            strDesc = "客户资料" & vbTab & "记录用户所有客户的相关信息。" & vbTab & "Customers"
'    End Select
    GetDescOfBaseTable = strDesc
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDatabase"
    m_tagErrInfo.strErrFunc = "GetDescOfBaseTable"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "获得基本信息表对应的描述说明性文字失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    GetDescOfBaseTable = ""
End Function

'**************************************************************
'获得系统进行数据库连接时使用的用户名和密码
'        strUserName = "C73#09M73@03W73_11X75$06"
'        strUserPassword = "SIdaiGAI503_LOUrong"
Public Function GetSysUserName() As String
    On Error GoTo ERROR_EXIT
    
    GetSysUserName = "C73#09M73@03W73_11X75$06"
    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 = "SIdaiGAI503_LOUrong"
    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

'*********************************
' 修复数据库，以进行数据库备份、恢复操作
' 目前主要是从注册表中获得数据库备份目录路径，然后刷新表 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
    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'