moddbset.bas

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

Attribute VB_Name = "modDBSet"
Option Explicit

Dim m_tagErrInfo                As TYPE_ERRORINFO       ' 错误信息

Public dbMyDB                   As ADODB.Connection
Public bolDBStatus              As Boolean              ' 是否连建数据库

'操作类型
Public Enum ENUM_OPTYPE
    OPTYPE_QUERY = 0            '查询状态
    OPTYPE_INSERT = 1           '增加操作
    OPTYPE_MODIFY = 2           '修改操作
    OPTYPE_DELETE = 3           '删除操作
    OPTYPE_AUDIT = 4            '审核操作
    OPTYPE_UNAUDIT = 5          '反审核操作
    OPTYPE_BLANK = 6            '作废操作
    OPTYPE_UNBLANK = 7          '反作废操作
End Enum

'数据库登陆信息记录
Private Type TYPE_USERDB
    strUserDatabase As String
    strUserDatasource As String
End Type

Public g_MyUserDB As TYPE_USERDB

Public Sub dbDataConnectSet(UserDBName As String, UserDBSource As String)
    g_MyUserDB.strUserDatabase = UserDBName
    g_MyUserDB.strUserDatasource = UserDBSource
End Sub

Public Function TurnOnMSDE(ByVal sServer As String, ByVal sLogin As String, _
    ByVal sPassword As String) As Boolean
    Dim oSvr As SQLDMO.SQLServer
    Dim i As Single, b As Boolean
    
    b = False
    Set oSvr = New SQLDMO.SQLServer
    On Error GoTo StartError
    oSvr.LoginTimeout = 60
    oSvr.Start True, sServer, sLogin, sPassword
    oSvr.Disconnect
    Set oSvr = Nothing
    If b = False Then
        i = Timer + 5
        While Timer < i
        Wend
    End If
    TurnOnMSDE = True
    Exit Function
StartError:
    If Err.Number = -2147023840 Then
        oSvr.Connect sServer, sLogin, sPassword
        b = True
        Resume Next
    End If
    If Err.Number = -2147023836 Then
        MsgBox "无法启动SQL Server服务！", vbOKOnly + vbExclamation, "严重错误！"
    End If
    oSvr.Disconnect
    Set oSvr = Nothing
    TurnOnMSDE = False
End Function

Public Function Init_DB_Connect() As Boolean
    On Error GoTo ERROR_EXIT
    
    Set dbMyDB = New ADODB.Connection
    TurnOnMSDE g_MyUserDB.strUserDatasource, "sa", "NOVA"
    
    dbMyDB.ConnectionString = _
        "Provider=SQLOLEDB.1;Persist Security Info=False;User ID = sa; " + _
        "Password = NOVA; Initial Catalog = " + g_MyUserDB.strUserDatabase + _
        ";Data Source=" + g_MyUserDB.strUserDatasource
    dbMyDB.Open
    
    Init_DB_Connect = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDBSet"
    m_tagErrInfo.strErrFunc = "Init_DB_Connect"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & "系统数据库打开失败!"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    Close
    MsgBox "系统数据库打开失败!", vbCritical + vbOKOnly, "系统错误"
    Init_DB_Connect = False
End Function

'将服务人员登录信息写入数据库, 0 - 登录, 1 - 离开
Public Function Login_Info_Save(ByVal socket As Integer, Optional ByVal iMode = 0) As Boolean
    On Error GoTo ERROR_EXIT
    Dim objUserState As clsUserState
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    Dim i As Integer, iResult As Integer
    
    '检查是否是第一个用户
    If IsArrayInit(user) = False And iMode = 1 Then
        Exit Function
    End If
    
    Set objUserState = New clsUserState
    Set objUserState.IBaseClass_ActiveConnection = dbMyDB
    
    iResult = -1
    For i = 0 To UBound(user)
        If user(i).socket = socket Then
            iResult = i
            Exit For
        End If
    Next i
    If iResult = -1 Then GoTo ERROR_EXIT
    
    If user(iResult).user_login = "" And user(iResult).user_name = "" Then
        GoTo ChangeUser
    End If
    
    objUserState.user_login = user(iResult).user_login
    objUserState.user_name = user(iResult).user_name
    
    '以下固定值，为兼容保留
    objUserState.computer_code = 0
    objUserState.st_type = 0
    
    Select Case iMode
        Case 0
            objUserState.us_type = 0
            objUserState.us_time = user(iResult).connected_at
        Case 1
            objUserState.us_type = 1
            objUserState.us_time = Date & " " & time
        Case Else
            GoTo ERROR_EXIT
    End Select
    
    '更新数据库
    If Not objUserState.IBaseClass_Insert Then
        MsgBox objUserState.IBaseClass_yxErr.Description, vbOKOnly, "数据库更新错误"
        GoTo ERROR_EXIT
    End If
    
    Set objUserState = Nothing
    
ChangeUser:         '修改user()结构
    If iMode = 1 Then
        '将保存的登录信息删除
        If UBound(user) = 0 Then
            Erase user
        Else
            If iResult < UBound(user) Then
                For i = iResult To UBound(user) - 1
                    user(i) = user(i + 1)
                Next i
                ReDim Preserve user(UBound(user) - 1)
            Else
                ReDim Preserve user(UBound(user) - 1)
            End If
        End If
    End If
    
    Login_Info_Save = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDBSet"
    m_tagErrInfo.strErrFunc = "Login_Info_Save"
    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 objUserState = Nothing
    
    If iMode = 1 Then
        '将保存的登录信息删除
        If UBound(user) = 0 Then
            Erase user
        Else
            If iResult < UBound(user) Then
                For i = iResult To UBound(user) - 1
                    user(i) = user(i + 1)
                Next i
                ReDim Preserve user(UBound(user) - 1)
            Else
                ReDim Preserve user(UBound(user) - 1)
            End If
        End If
    End If
    
    Login_Info_Save = False
End Function

Public Function Save_Password(ByVal socket As Integer, ByVal data As String) As Boolean
    On Error GoTo ERROR_EXIT
    Dim sFunction As String, sPara() As String
    Dim i As Integer, iResult As Integer, iTrans As Integer
    
    sPara = Split(data, vbTab)
    sFunction = UCase(sPara(0))
    If UBound(sPara) = 0 Then GoTo ERROR_EXIT
    If sFunction <> "PCWD" Then GoTo ERROR_EXIT
    
    '获得员工工号
    sFunction = ""
    modCipher.Decipher "CoBeyond_Queue_Yixing", sPara(1), sFunction
    sFunction = Trim$(sFunction)
    
    '合法登陆
    iResult = -1
    For i = 0 To UBound(user)
        If user(i).socket = socket And user(i).service_state = True Then
            iResult = i
            Exit For
        End If
    Next i
    
    If Trim$(sPara(3)) = "" Then sPara(3) = "                "
    
    '修改密码
    iTrans = dbMyDB.BeginTrans
    dbMyDB.Execute "UPDATE Employee SET [property] = '" & sPara(3) & "' " & _
                "WHERE [ep_code] = '" & sFunction & "'"
    If iTrans > 0 Then
        dbMyDB.CommitTrans
        iTrans = 0
    End If
    
    Save_Password = True
    Exit Function
ERROR_EXIT:
    If iTrans > 0 Then dbMyDB.RollbackTrans
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modDBSet"
    m_tagErrInfo.strErrFunc = "Save_Password"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo

    Save_Password = False
End Function