clsuserstate.cls

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

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsUserState"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_ActiveConnection              As ADODB.Connection
Private m_yxErr                         As New CYXError             '错误对象
Private m_strObjPrefix As String
Private m_strTableName As String                                    '对象所对应的表的名称
Private m_strParentKey As String

Public us_id            As Integer      '数据编号       int             N
Public computer_code    As String       '类型编码       int         4   N
Public st_type          As Byte         '数据表编码     tinyint     1   N
Public us_type          As Byte         '登录状态       tinyint     1   N
Public us_time          As String       '状态发生时间   datatime    8   N
Public user_login       As String       '员工工号       nvarchar    50  Y
Public user_name        As String       '登录员工       nvarchar    50  Y

'''''''''''''''''''
' 根据 Recordset 设置对象
Private Function IBaseClass_RecordSet(ByVal rs As ADODB.Recordset) As Boolean
    On Error GoTo ERROR_DEFAULT
    
    If rs Is Nothing Then GoTo ERROR_DEFAULT
    If rs.EOF Then GoTo ERROR_DEFAULT
    
    If Not IsNull(rs!us_id) Then us_id = rs!us_id
    If Not IsNull(rs!computer_code) Then computer_code = rs!computer_code
    If Not IsNull(rs!st_type) Then st_type = rs!st_type
    If Not IsNull(rs!us_type) Then us_type = rs!us_type
    
    If Not IsNull(rs!us_time) Then us_time = rs!us_time
    If Not IsNull(rs!user_login) Then user_login = rs!user_login
    If Not IsNull(rs!user_name) Then user_name = rs!user_name
    
    IBaseClass_RecordSet = True
    Exit Function
ERROR_DEFAULT:
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_RecordSet"
    IBaseClass_RecordSet = False
End Function

'''''''''''''''''''
'查询操作，如果操作成功则将自身设置为返回的对象
' 如果 strSQL 为空，则根据 us_id 查询
Public Function IBaseClass_Query(Optional ByVal strSQL As String = "") As Boolean
    On Error GoTo ERROR_DEFAULT
    Dim cmd As New ADODB.command, rs As New ADODB.Recordset
    
    If m_ActiveConnection Is Nothing Then GoTo ERROR_DEFAULT
    Set cmd.ActiveConnection = m_ActiveConnection
    cmd.CommandType = adCmdText
    cmd.CommandText = IIf(Trim(strSQL) <> "", strSQL, _
        "SELECT * FROM " & m_strTableName & " WHERE us_id = " & us_id)
    
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    Set rs.ActiveConnection = Nothing
    If rs.EOF Then GoTo ERROR_DEFAULT
    If rs.RecordCount <> 1 Then GoTo ERROR_DEFAULT
    If Not IBaseClass_RecordSet(rs) Then GoTo ERROR_DEFAULT
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IBaseClass_Query = True
    Exit Function
ERROR_DEFAULT:
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_Query"
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IBaseClass_Query = False
End Function

'''''''''''''''''''
'检查操作是否能进行
Public Function IBaseClass_CanDo(ByVal optype As ENUM_OPTYPE) As Boolean
    On Error GoTo ERROR_DEFAULT
    Dim cmd As New ADODB.command, rs As New ADODB.Recordset
    
    If m_ActiveConnection Is Nothing Then GoTo ERROR_DEFAULT
    Set cmd.ActiveConnection = m_ActiveConnection
    cmd.CommandType = adCmdText
    
    '检查数据完整性
    If optype = ENUM_OPTYPE.OPTYPE_INSERT Or optype = ENUM_OPTYPE.OPTYPE_MODIFY Then
        If Trim$(computer_code) = "" Then
            m_yxErr.Raise , "服务计算机编号不得为空。"
            GoTo ERROR_DEFAULT
        End If
        
        If Not IsNumeric(st_type) Then
            m_yxErr.Raise , "服务计算机类型输入错误。"
            GoTo ERROR_DEFAULT
        End If
        
        If Not IsNumeric(us_type) Then
            m_yxErr.Raise , "服务计算机登录状态错误。"
            GoTo ERROR_DEFAULT
        End If
        
        If Trim$(us_time) = "" Then
            m_yxErr.Raise , "登录时间输入错误。"
            GoTo ERROR_DEFAULT
        End If
    End If
    
    '检查数据合法性
    If optype <> OPTYPE_INSERT Then
        If rs.State = adStateOpen Then rs.Close
        cmd.CommandText = "SELECT * FROM " & m_strTableName & " WHERE us_id = '" & us_id & "'"
        rs.CursorLocation = adUseClient
        rs.Open cmd, , adOpenStatic, adLockReadOnly
        If rs.RecordCount <> 1 Then
            m_yxErr.Raise , "登录信息无效。"
            GoTo ERROR_DEFAULT
        End If
    End If
    
    Select Case optype
        Case ENUM_OPTYPE.OPTYPE_INSERT        '增加操作
            If rs.State = adStateOpen Then rs.Close
            cmd.CommandText = "SELECT * FROM " & m_strTableName & " WHERE computer_code = '" & computer_code & "' " & _
                              "AND st_type = '" & st_type & "' " & _
                              "AND us_type = '" & us_type & "' " & _
                              "AND us_time = '" & us_time & "' " & _
                              "AND user_login = '" & user_login & "'"
            rs.CursorLocation = adUseClient
            rs.Open cmd, , adOpenStatic, adLockReadOnly
            If rs.RecordCount > 0 Then
                m_yxErr.Raise , "登录信息已经存在。"
                GoTo ERROR_DEFAULT
            End If
        Case ENUM_OPTYPE.OPTYPE_MODIFY          '修改操作
            If rs.State = adStateOpen Then rs.Close
            cmd.CommandText = "SELECT * FROM " & m_strTableName & " WHERE us_id <> '" & us_id & "'"
            rs.CursorLocation = adUseClient
            rs.Open cmd, , adOpenStatic, adLockReadOnly
            If rs.RecordCount > 0 Then
                m_yxErr.Raise , "登录信息重复存在。"
                GoTo ERROR_DEFAULT
            End If
        Case ENUM_OPTYPE.OPTYPE_DELETE          '删除操作
            
        Case Else ' OPTYPE_AUDIT , OPTYPE_UNAUDIT
            GoTo ERROR_DEFAULT
    End Select
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IBaseClass_CanDo = True
    Exit Function
ERROR_DEFAULT:
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_CanDo"
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    IBaseClass_CanDo = False
End Function

'''''''''''''''''''
'删除操作
Public Function IBaseClass_Delete() As Boolean
    On Error GoTo ERROR_DEFAULT
    Dim iTrans As Integer
    
    If m_ActiveConnection Is Nothing Then GoTo ERROR_DEFAULT
    If Not IBaseClass_CanDo(ENUM_OPTYPE.OPTYPE_DELETE) Then GoTo ERROR_DEFAULT
    
    iTrans = m_ActiveConnection.BeginTrans
    m_ActiveConnection.Execute "DELETE FROM " & m_strTableName & " WHERE us_id = '" & us_id & "'"
    If iTrans > 0 Then
        m_ActiveConnection.CommitTrans
        iTrans = 0
    End If
    
    IBaseClass_Delete = True
    Exit Function
ERROR_DEFAULT:
    If iTrans > 0 Then m_ActiveConnection.RollbackTrans
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_Delete"
    IBaseClass_Delete = False
End Function

'''''''''''''''''''
'修改操作
Public Function IBaseClass_Modify() As Boolean
    On Error GoTo ERROR_DEFAULT
    Dim iTrans As Integer
    
    If m_ActiveConnection Is Nothing Then GoTo ERROR_DEFAULT
    If Not IBaseClass_CanDo(ENUM_OPTYPE.OPTYPE_MODIFY) Then GoTo ERROR_DEFAULT
    
    iTrans = m_ActiveConnection.BeginTrans
    m_ActiveConnection.Execute "UPDATE " & m_strTableName & " SET [computer_code] = '" & computer_code & "', " & _
                "[st_type] = '" & st_type & "', [us_type] = '" & us_type & "' , " & _
                "[us_time] = '" & us_time & "', [user_login] = '" & user_login & "', " & _
                "[user_name] = '" & user_name & "'"
    If iTrans > 0 Then
        m_ActiveConnection.CommitTrans
        iTrans = 0
    End If
        
    IBaseClass_Modify = True
    Exit Function
ERROR_DEFAULT:
    If iTrans > 0 Then m_ActiveConnection.RollbackTrans
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_Modify"
    IBaseClass_Modify = False
End Function

'''''''''''''''''''
'增加操作
Public Function IBaseClass_Insert() As Boolean
    On Error GoTo ERROR_DEFAULT
    Dim iTrans As Integer
    
    If m_ActiveConnection Is Nothing Then GoTo ERROR_DEFAULT
    If Not IBaseClass_CanDo(ENUM_OPTYPE.OPTYPE_INSERT) Then GoTo ERROR_DEFAULT
    
    iTrans = m_ActiveConnection.BeginTrans
    '向表中插入数据
    m_ActiveConnection.Execute "INSERT INTO " & m_strTableName & "([computer_code], [st_type]," _
                & "[us_type],[us_time],[user_login],[user_name]) " _
                & "VALUES( '" & computer_code & "', '" & st_type & "', '" & us_type & "', " _
                & "'" & us_time & "', '" & user_login & "', '" & user_name & "')"
    If iTrans > 0 Then
        m_ActiveConnection.CommitTrans
        iTrans = 0
    End If
                
    IBaseClass_Insert = True
    Exit Function
ERROR_DEFAULT:
    If iTrans > 0 Then m_ActiveConnection.RollbackTrans
    If Err <> 0 Then m_yxErr.Raise Err, Err.Description, Err.Source, "IBaseClass_Insert"
    IBaseClass_Insert = False
End Function

Private Sub Class_Initialize()
    m_strObjPrefix = "USER_STATE_CLASS"
    m_strTableName = "UserState"
    m_yxErr.ObjectName = TypeName(Me)
End Sub

Public Property Get IBaseClass_ParentKey() As String
    If m_strParentKey = "" Then
        IBaseClass_ParentKey = ""
    Else
        IBaseClass_ParentKey = m_strParentKey
    End If
End Property

Public Property Let IBaseClass_ParentKey(strParent As String)
    m_strParentKey = strParent
End Property

Public Property Get IBaseClass_Key(Optional ByVal strID As String = "") As String
    If strID <> "" Then
        IBaseClass_Key = m_strObjPrefix & strID
        Exit Property
    End If
    IBaseClass_Key = m_strObjPrefix & us_id
End Property

Public Property Get IBaseClass_TableName() As String
    IBaseClass_TableName = m_strTableName
End Property

Public Property Get IBaseClass_yxErr() As CYXError
    Set IBaseClass_yxErr = m_yxErr
End Property

Public Property Get IBaseClass_Prefix() As String
    IBaseClass_Prefix = m_strObjPrefix
End Property

Friend Property Let IBaseClass_Prefix(str As String)
    m_strObjPrefix = str
End Property

Public Property Set IBaseClass_ActiveConnection(ByVal vData As ADODB.Connection)
    If Not vData Is Nothing Then Set m_ActiveConnection = vData
End Property

Public Property Get IBaseClass_ActiveConnection() As ADODB.Connection
    Set IBaseClass_ActiveConnection = m_ActiveConnection
End Property