moddatabase.bas

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

    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

'***********************************************************************************************************
' 获得本地系统信息
' Added by Jack Xu 2001.11.2
'   1. GetCurComputerName       获得本地机器名
'   2. RunningOnDBServer        判断系统是否在数据库服务器上运行
'   3. GetUserName              获得登陆用户名
'   4. GetSysPath               获得本地系统安装目录路径
'   5. SetUserName              设置登陆用户名
'   6. GetSQLServerName         获得数据库服务器名
'***********************************************************************************************************
'***********************************************************************************************************
' 获得本地机器名
' Added by Jack Xu 2001.11.2

Public Function GetCurComputerName() As String
    On Error GoTo ERROR_EXIT
    Dim fOK As Boolean
    Dim strName As String
    Dim nSize As Long
    
    fOK = False
    If m_strComputerName = "" Then
        nSize = 255
        strName = Space(nSize)
        fOK = GetComputerName(strName, nSize)
        If Not fOK Then GoTo ERROR_EXIT
        strName = RemoveNullChar(Trim(strName))
        m_strComputerName = strName
    Else
        fOK = True
    End If
    
    If fOK Then
        GetCurComputerName = Trim(m_strComputerName)
        Exit Function
    End If
    
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "GetCurComputerName"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    GetCurComputerName = ""
End Function

'***********************************************************************************************************
'   获得数据库服务器名
Public Function GetSQLServerName() As String
    On Error GoTo ERROR_EXIT
    If Trim(g_MyUserDB.strUserDatasource) = "." Then
        GetSQLServerName = GetCurComputerName
    Else
        GetSQLServerName = Trim(g_MyUserDB.strUserDatasource)
    End If
    
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "GetSQLServerName"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    GetSQLServerName = ""
End Function

'***********************************************************************************************************
'   判断系统是否在数据库服务器上运行
Public Function RunningOnSQLServer() As Boolean
    On Error GoTo ERROR_EXIT
    Dim strComputerName As String
    
    If Trim(g_MyUserDB.strUserDatasource) = "." Then
            RunningOnSQLServer = True
    Else
        strComputerName = Trim(GetCurComputerName)
        If strComputerName = "" Then GoTo ERROR_EXIT
        If UCase(strComputerName) = UCase(Trim(g_MyUserDB.strUserDatasource)) Then
            RunningOnSQLServer = True
        Else
            RunningOnSQLServer = False
        End If
    End If
    
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "GetCurComputerName"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    RunningOnSQLServer = False
End Function

'***********************************************************************************************************
'   设置登陆用户名
Public Function SetUserName(ByVal strUserName As String)
    On Error Resume Next
    m_strUserName = strUserName
End Function

'   获得登陆用户名
Public Function GetUserName() As String
    On Error Resume Next
    GetUserName = m_strUserName
End Function

'***********************************************************************************************************
'   获得本地系统安装目录路径
'   要求从本机注册表中获得安装目录路径，这里暂时使用固定目录 D:\CYCRM 。
Public Function GetSysPath() As String
    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 = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyCRM\1.21"
    If Not clsReg.CreateKey(eHKEY_LOCAL_MACHINE, strRegRoot) Then GoTo ERROR_EXIT1
    GetSysPath = CStr(clsReg.GetValue(eHKEY_LOCAL_MACHINE, strRegRoot & "\CLIENT", "Path"))
    Set clsReg = Nothing
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "GetCurComputerName"
    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 clsReg = Nothing
    GetSysPath = ""
End Function

'********************************************************************************************
'CREATOR:     FengJie    2001.11.1
'函数功能:    记录登陆,登出日志
'参数说明:    strlogname----------登陆或登出名
'             strlogpwd-----------登陆或登出密码
'             nlogstatus----------登陆或登出状态(0---未知,1---登陆成功,2---登陆失败,3---登出)
'存储过程:    SPEX_LOGGING_LOG
'数据库表:    T_LOGON
'********************************************************************************************
Public Function LogRecord(ByVal strLogName As String, _
                          ByVal strlogpwd As String, _
                          ByVal nlogstatus As Integer, _
                          ByVal strVersion As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
    Dim strCoumuterName As String
    Dim iTrans As Integer
    
    strCoumuterName = GetCurComputerName
    
    iTrans = dbMyDB.BeginTrans
    
    dbMyDB.Execute "INSERT INTO T_LOGON(log_name,log_password,log_time,log_status,log_computer,log_version)" & _
            " VALUES ('" & strLogName & "','" & strlogpwd & "','" & Date & "','" & nlogstatus & "','" & _
            strCoumuterName & "','" & strVersion & "' )"
    
    If iTrans > 0 Then
        dbMyDB.CommitTrans
        iTrans = 0
    End If
    
    LogRecord = True
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    If iTrans > 0 Then dbMyDB.RollbackTrans
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "LogRecord"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "记录登陆,登出日志操作失败。"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    LogRecord = False
    Set rs = Nothing
    Set cmd = Nothing
End Function