modparameter.bas

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

Attribute VB_Name = "modParameter"
Option Explicit

Dim m_tagErrInfo                As TYPE_ERRORINFO       ' 错误信息

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 注册表信息
Public Const g_strREG_SERVER_KEY = "SOFTWARE\Shanghai YiXing Tech. Ltd. Co. \CyQueue\1.21\Server"
Public Const g_strREG_MSSQL_SETUP_KEY = "SOFTWARE\Microsoft\MSSQLServer\Setup"

Private Type TYPE_USERDB
    strUserName As String
    strUserPassword As String
    strUserDatabase As String
    strUserDatasource As String
End Type
Public g_MyUserDB As TYPE_USERDB

Public bolDBStatus          As Boolean
Public dbMyDB               As ADODB.Connection

Public m_strUser            As String                   '用户登录名称
Public m_strOld             As String                   '用户登录名称明文
Public m_strPass            As String                   '用户登录密码
Public m_iUser              As Integer                  '用户编号

Public m_iRefresh           As Long                     '刷新时间
Public m_bStatus            As Boolean                  '状态窗口是否显示

'初始化时间管理设置
Public Function InitSYS() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    
    '初始化时间设置,缺省60秒
    m_iRefresh = 60000
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    strSQL = "SELECT * FROM SystemSet "
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount = 1 Then
        rs.MoveFirst
        m_iRefresh = rs!system_refresh * 1000
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    strSQL = ""
    
    InitSYS = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modParameter"
    m_tagErrInfo.strErrFunc = "InitSYS"
    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
    InitSYS = False
End Function

'刷新排队队列信息
Public Sub Refresh_Info()
    On Error Resume Next
    Refresh_Status
    If m_bStatus = True Then
        frmQueueState.InitTreeView
        frmQueueState.InitChart
    End If
End Sub

'/////////////////////////////////////////////////////////////////
'/刷新状态条
Private Sub Refresh_Status()
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, iResult As Integer
    
    iResult = 0
        
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    '求计算机编号
    strSQL = "SELECT * FROM VIEW_Queue_Customer_Change WHERE service_date = '" & Date & "'"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        iResult = rs.RecordCount
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    strSQL = "SELECT * FROM VIEW_QUEUE_Customer_Start WHERE service_date = '" & Date & "'"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        iResult = iResult + rs.RecordCount
    End If
    rs.Close
    
    '更新当前排队人数图
    mdiQueue.stbMDIStatus.Panels(2).Text = "当前总排队人数: " & CStr(iResult)
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "modParameter"
    m_tagErrInfo.strErrFunc = "Refresh_Status"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub