modstartup.bas

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

    End If
    strSearchChar = """"
    i = 0
    i = InStr(1, strMask, strSearchChar, 1)
    If i <> 0 Then
        strArray() = Split(strMask, strSearchChar, -1, vbTextCompare)
        strMask = Join(strArray, vbTab)
    End If
    MaskString = strMask
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "MaskString"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
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, _
                          ByVal cnn As ADODB.Connection) As Boolean
    On Error GoTo ERROR_EXIT
    Dim cmd As New ADODB.Command
    Dim strCoumuterName As String
    
    strCoumuterName = GetCurComputerName
    With cmd
        Set .ActiveConnection = cnn
        .CommandType = adCmdStoredProc
        .CommandText = "SPEX_LOGGING_LOG"
        .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue, , Null)
        .Parameters.Append .CreateParameter("log_name", adVarChar, adParamInput, 128, strLogName)
        .Parameters.Append .CreateParameter("log_password", adVarChar, adParamInput, 128, strlogpwd)
        .Parameters.Append .CreateParameter("log_status", adInteger, adParamInput, , nlogstatus)
        .Parameters.Append .CreateParameter("log_computer", adVarChar, adParamInput, 255, strCoumuterName)
        .Parameters.Append .CreateParameter("log_version", adVarChar, adParamInput, 64, strVersion)
        .Execute
        '判断存储过程返回值
        If CLng(.Parameters("RETURN_VALUE").Value) <> 0 Then
            Debug.Print "--Error(dlgLogOn - LogOnRecord ):调用存储过程" & vbCrLf & _
                    vbTab & " SPEX_LOGGING_LOG 出错。" & vbCrLf & _
                    vbTab & "返回值为 " & .Parameters("RETURN_VALUE").Value
            GoTo ERROR_EXIT
        End If
    End With
    LogRecord = True
    
    Set cmd = Nothing
    Exit Function
ERROR_EXIT:
    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 cmd = Nothing
End Function

'***********************************************************************************************************
' 获得本地机器名
' 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

'***********************************************************************************************************
'   获得本地系统安装目录路径
'   要求从本机注册表中获得安装目录路径，这里暂时使用固定目录 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

'*******************************************************
'将完整文件名分解为路径名和短文件名
Public Function FilterFileName(ByVal strFullName As String, _
                                ByRef strPath As String, _
                                ByRef strFile As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim strShortFileName As String
    Dim nPos As Long
    
    If Trim(strFullName) = "" Then GoTo ERROR_EXIT
    strShortFileName = strFullName
    nPos = InStr(strShortFileName, "\")
    While nPos > 0
        strShortFileName = Right(strShortFileName, Len(strShortFileName) - nPos)
        nPos = InStr(strShortFileName, "\")
    Wend
    strPath = Left(strFullName, Len(strFullName) - Len(strShortFileName))
    strFile = strShortFileName
    
    FilterFileName = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modStartup"
    m_tagErrInfo.strErrFunc = "CheckFileNameExist"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    FilterFileName = False
End Function

'**********************************
' 去掉字符中的空字符及以后的字符
Public Function RemoveNullChar(ByVal str As String) As String
    Dim i As Integer
    Dim strTemp As String
    
    strTemp = str
    i = InStr(strTemp, vbNullChar)
    If i > 0 Then strTemp = Left(strTemp, i - 1)
    RemoveNullChar = strTemp
End Function

'-----------------------------------------------------------
' SUB: AddDirSep
' Add a trailing directory path separator (back slash) to the
' end of a pathname unless one already exists
'
' IN/OUT: [strPathName] - path to add separator to
'-----------------------------------------------------------
'
Public Sub AddDirSep(strPathName As String)
    If Right(Trim(strPathName), Len("\")) <> "\" Then
        strPathName = RTrim$(strPathName) & "\"
    End If
End Sub