frmqueuestate.frm

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

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{65E121D4-0C60-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCHRT20.OCX"
Begin VB.Form frmQueueState 
   Caption         =   "当前排队状态"
   ClientHeight    =   6015
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8415
   Icon            =   "frmQueueState.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   6015
   ScaleWidth      =   8415
   WindowState     =   2  'Maximized
   Begin MSComctlLib.ImageList img1 
      Left            =   3120
      Top             =   5400
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   2
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmQueueState.frx":0CCA
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmQueueState.frx":1064
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Frame fra3 
      Caption         =   "排队队列"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   5775
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   2535
      Begin MSComctlLib.TreeView trvQueue 
         Height          =   5415
         Left            =   120
         TabIndex        =   6
         Top             =   240
         Width           =   2295
         _ExtentX        =   4048
         _ExtentY        =   9551
         _Version        =   393217
         Indentation     =   529
         LabelEdit       =   1
         Style           =   7
         FullRowSelect   =   -1  'True
         ImageList       =   "img1"
         Appearance      =   1
      End
   End
   Begin VB.Frame fraWait 
      Caption         =   "最长初始等待时间(分)"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2415
      Left            =   2760
      TabIndex        =   3
      Top             =   2880
      Width           =   5535
      Begin MSChart20Lib.MSChart mscWait 
         Height          =   2055
         Left            =   120
         OleObjectBlob   =   "frmQueueState.frx":13FE
         TabIndex        =   4
         TabStop         =   0   'False
         Top             =   240
         Width           =   5295
      End
   End
   Begin VB.Frame fraNumber 
      Caption         =   "当前服务排队人数(个)"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2415
      Left            =   2760
      TabIndex        =   1
      Top             =   120
      Width           =   5535
      Begin MSChart20Lib.MSChart mscNumber 
         Height          =   2055
         Left            =   120
         OleObjectBlob   =   "frmQueueState.frx":31FF
         TabIndex        =   2
         TabStop         =   0   'False
         Top             =   240
         Width           =   5295
      End
   End
   Begin VB.CommandButton cmdQuit 
      Caption         =   "关闭(&C)"
      Height          =   375
      Left            =   7200
      TabIndex        =   0
      Top             =   5520
      Width           =   1095
   End
   Begin VB.CommandButton cmdRefresh 
      Caption         =   "刷新(&R)"
      Height          =   375
      Left            =   6120
      TabIndex        =   7
      Top             =   5520
      Width           =   1095
   End
End
Attribute VB_Name = "frmQueueState"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim m_tagErrInfo    As TYPE_ERRORINFO

Dim m_bChoice       As Boolean                          '是否选择了 TreeView 的选项
Dim m_sChoice       As String                           '选择的 TreeView 的选项的 Key

Private Sub cmdQuit_Click()
    On Error Resume Next
    Unload Me
End Sub

Private Sub cmdRefresh_Click()
    On Error Resume Next
    Dim i As Integer
    
    '清除图表信息
    mscNumber.Column = 1
    For i = 1 To mscNumber.RowCount
        mscNumber.Row = i
        mscNumber.Data = 0
    Next i
    mscWait.Column = 1
    For i = 1 To mscWait.RowCount
        mscWait.Row = i
        mscWait.Data = 0
    Next i
    m_bChoice = False
    m_sChoice = ""
    
    InitTreeView
End Sub

Private Sub Form_Activate()
    On Error Resume Next
    m_bStatus = True
End Sub

Private Sub Form_Load()
    On Error GoTo ERROR_EXIT
    Dim i As Integer
    
    '清除图表信息
    mscNumber.Column = 1
    For i = 1 To mscNumber.RowCount
        mscNumber.Row = i
        mscNumber.Data = 0
    Next i
    mscWait.Column = 1
    For i = 1 To mscWait.RowCount
        mscWait.Row = i
        mscWait.Data = 0
    Next i
    
    m_bChoice = False
    m_sChoice = ""
    If InitTreeView = False Then GoTo ERROR_EXIT
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueState"
    m_tagErrInfo.strErrFunc = "Form_Load"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Dim i As Integer, j As Integer

    If Me.WindowState = 1 Then Exit Sub
    
    If Me.Width < 8535 Then Me.Width = 8535
    If Me.Height < 6420 Then Me.Height = 6420
    
    i = Me.Width - 8535
    j = Me.Height - 6420

    '修改宽度
    fra3.Width = i + 2535
    trvQueue.Width = i + 2295
        
    fraNumber.Left = i + 2760
    fraWait.Left = i + 2760
    cmdRefresh.Left = i + 6120
    cmdQuit.Left = i + 7200
    
    '修改高度位置
    fra3.Height = j + 5775
    trvQueue.Height = j + 5415
    
    fraNumber.Height = j / 2 + 2415
    mscNumber.Height = j / 2 + 2055
    fraWait.Height = j / 2 + 2415
    mscWait.Height = j / 2 + 2055
    
    fraWait.Top = j / 2 + 2880
    cmdRefresh.Top = j + 5520
    cmdQuit.Top = j + 5520
End Sub

Private Sub Form_Terminate()
    On Error Resume Next
    Set frmSeatSet = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    m_bStatus = False
End Sub

Private Sub trvQueue_NodeClick(ByVal Node As MSComctlLib.Node)
    On Error GoTo ERROR_EXIT
    
    If Node.Root.Text = Node.Text Then
        m_bChoice = True
        m_sChoice = Mid$(Node.Key, 1, InStr(Node.Key, vbTab) - 1)
    Else
        m_bChoice = False
        m_sChoice = ""
    End If
    
    InitChart
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueState"
    m_tagErrInfo.strErrFunc = "trvQueue_NodeClick"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

'////////////////////////////////////////////////////////////////////////////////////////////////////
'/初始化系统中 TreeView
Public Function InitTreeView() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, i As Integer
    Dim ndObject As Node
    
    trvQueue.Nodes.Clear
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
            
    '查询数据库
    strSQL = "SELECT * FROM Style WHERE st_type = 1 AND nouse_yesno = 0"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        rs.MoveFirst
        For i = 1 To rs.RecordCount
            Set ndObject = trvQueue.Nodes.Add(, , rs!st_code & vbTab & rs!st_name, rs!st_name)
            ndObject.Image = 2
            rs.MoveNext
        Next i
    Else
        InitTreeView = False
        Exit Function
    End If
    rs.Close
    
    '加入排队队列; 客户编号,到达时间,转队列服务
    If rs.State = adStateOpen Then rs.Close
    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
        rs.MoveFirst
        For i = 1 To rs.RecordCount
            Set ndObject = trvQueue.Nodes.Add(rs!service_code & vbTab & rs!service_name, _
                           tvwChild, rs!customer_id & vbTab & rs!service_date, _
                           rs!customer_id & " " & rs!start_time & " " & "转换队列")
            ndObject.Image = 1
            rs.MoveNext
        Next i
    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
        rs.MoveFirst
        For i = 1 To rs.RecordCount
            Set ndObject = trvQueue.Nodes.Add(rs!service_code & vbTab & rs!service_name, _
                           tvwChild, rs!customer_id & vbTab & rs!service_date, _
                           rs!customer_id & " " & rs!start_time & " " & "初始队列")
            ndObject.Image = 1
            rs.MoveNext
        Next i
    End If
    rs.Close
    
    For i = 1 To trvQueue.Nodes.Count
        trvQueue.Nodes(i).Expanded = True
    Next i
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    InitTreeView = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueState"
    m_tagErrInfo.strErrFunc = "InitTreeView"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    InitTreeView = False
End Function

'初始化 Chart 控件
Public Function InitChart() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String, iResult As Integer, i As Integer
    Dim sTime As String
    
    If m_bChoice = False Or m_sChoice = "" Then
        '清除图表信息
        mscNumber.Column = 1
        For i = 1 To mscNumber.RowCount
            mscNumber.Row = i
            mscNumber.Data = 0
        Next i
        mscWait.Column = 1
        For i = 1 To mscWait.RowCount
            mscWait.Row = i
            mscWait.Data = 0
        Next i
        InitChart = False
        Exit Function
    End If
    
    '刷新当前排队人数图
    mscNumber.Column = 1
    For i = 1 To mscNumber.RowCount - 1
        mscNumber.Row = i + 1
        iResult = mscNumber.Data
        mscNumber.Row = i
        mscNumber.Data = iResult
    Next i
    '刷新当前平均排队时间
    mscWait.Column = 1
    For i = 1 To mscWait.RowCount - 1
        mscWait.Row = i + 1
        iResult = mscWait.Data
        mscWait.Row = i
        mscWait.Data = iResult
    Next i
    
    iResult = 0
        
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    '求计算机编号
    strSQL = "SELECT * FROM VIEW_Queue_Customer_Change WHERE service_date = '" & Date & _
             "' AND service_code = '" & m_sChoice & "'"
    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
    
    sTime = Date & " " & Time
    If rs.State = adStateOpen Then rs.Close
    strSQL = "SELECT * FROM VIEW_QUEUE_Customer_Start WHERE service_date = '" & Date & _
             "' AND service_code = '" & m_sChoice & "'"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount > 0 Then
        iResult = iResult + rs.RecordCount
        For i = 1 To rs.RecordCount
            If TimeValue(sTime) > TimeValue(rs!start_time) Then
                sTime = rs!start_time
            End If
            rs.MoveNext
        Next i
    End If
    rs.Close
    
    '更新当前排队人数图
    mscNumber.Column = 1
    mscNumber.Row = mscNumber.RowCount
    mscNumber.Data = iResult
    
    '更新最大等待时间
    iResult = DateDiff("n", sTime, Date & " " & Time)
    mscWait.Column = 1
    mscWait.Row = mscWait.RowCount
    mscWait.Data = iResult
    
    InitChart = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueueState"
    m_tagErrInfo.strErrFunc = "InitChart"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    InitChart = False
End Function