frmbizstatuslist.frm

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

            rs.MoveNext
        Next i
    End If
    rs.Close
    
    If cboService.ListCount > 0 Then cboService.ListIndex = 0
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    InitListInfo
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmBizStatusList"
    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

    '修改宽度
    fra2(1).Width = i + 3255
    cboService.Width = i + 3015
    
    fra1.Width = i + 8175
    lsvService.Width = i + 7935
    
    cmdRefresh.Left = i + 6120
    cmdQuit.Left = i + 7200
    
    '修改高度位置
    fra1.Height = j + 4575
    lsvService.Height = j + 4215
    
    cmdPreview.Top = j + 5520
    cmdPrint.Top = j + 5520
    cmdRefresh.Top = j + 5520
    cmdQuit.Top = j + 5520
End Sub

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

Private Sub opt1_Click(Index As Integer)
    On Error Resume Next
    m_iDateLen = Index
End Sub

'//////////////////////////////////////////////////////////////////////////////////////
'/显示当前的数据
Private Function InitListInfo() 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, j As Integer
    Dim itmX As ListItem, m As Long
    Dim sTime1 As String, sTime2 As String, sTime As String, l As Long
    Dim iHour As Long, iMinute As Long, iSecond As Long
    Dim iNum1() As Integer, iNum2() As Integer, iNum3() As Integer, iNum4() As Integer
    Dim sNum1() As Long, sNum2() As Long, sNum3() As Long, sNum4() As Long
    Dim sHead() As String
    
    lsvService.ListItems.Clear
    If Init_Time_Set = False Then GoTo ERROR_EXIT
    
    '计算时间段
    l = DateDiff("n", my_time_set.time_start, my_time_set.time_end)
    If m_iDateLen = 0 Then
        i = Int(l / 30 + 0.5)
    Else
        i = Int(l / 60 + 0.5)
    End If
    ReDim iNum2(i)
    ReDim iNum3(i)
    ReDim iNum4(i)
    ReDim sNum1(i)
    ReDim sNum2(i)
    ReDim sNum3(i)
    ReDim sNum4(i)
    ReDim sHead(i)
    sHead(0) = my_time_set.time_start
    sHead(i) = my_time_set.time_end
    For j = 1 To i - 1
        If m_iDateLen = 0 Then
            sHead(j) = DateAdd("n", 30, sHead(j - 1))
        Else
            sHead(j) = DateAdd("n", 60, sHead(j - 1))
        End If
    Next j
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    '查询数据库
    strSQL = "SELECT * FROM VIEW_LIST_Emp_Service WHERE cq_start_data = '" & DateValue(m_sDate) & _
         "' AND service_queue = '" & m_sService & "' ORDER BY cq_code"
    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
            If Not IsNull(rs!start_time) Then
                sTime1 = TimeValue(rs!start_time)
            End If
            If Not IsNull(rs!end_time) Then
                sTime2 = TimeValue(rs!end_time)
            End If
            
            '服务时间
            l = DateDiff("s", sTime1, sTime2)
            
            '等待时间
            If Not IsNull(rs!wait_time) Then
                sTime = TimeValue(rs!wait_time)
            End If
            m = Hour(sTime) * 3600 + Minute(sTime) * 60 + Second(sTime)
            
            For j = 1 To UBound(sHead)
                If TimeValue(sTime1) >= TimeValue(sHead(j - 1)) And TimeValue(sTime1) < TimeValue(sHead(j)) Then
                    iNum2(j) = iNum2(j) + 1
                    sNum1(j) = sNum1(j) + m
                    If sNum2(j) < m Then sNum2(j) = m
                End If
                If TimeValue(sTime2) >= TimeValue(sHead(j - 1)) And TimeValue(sTime2) < TimeValue(sHead(j)) Then
                    If rs!end_state = 1 Then iNum4(j) = iNum4(j) + 1
                    If rs!end_state <> 1 And rs!end_state <> 2 Then
                        iNum3(j) = iNum3(j) + 1
                        sNum3(j) = sNum3(j) + l
                        If sNum4(j) < l Then sNum4(j) = l
                    End If
                End If
            Next j
            
            rs.MoveNext
        Next i
    End If
    rs.Close
    
    For i = 1 To UBound(sHead)
        Set itmX = lsvService.ListItems.Add(, , sHead(i - 1) & "-" & sHead(i))
        itmX.SubItems(2) = iNum2(i)
        itmX.SubItems(3) = iNum3(i)
        itmX.SubItems(8) = iNum4(i)
        
        '平均等待时间
        If iNum2(i) <> 0 Then
            l = sNum1(i) / iNum2(i)
        Else
            l = 0
        End If
        iHour = l / 3600
        iMinute = (l - iHour * 3600) / 60
        iSecond = l - iHour * 3600 - iMinute * 60
        sTime = TimeSerial(iHour, iMinute, iSecond)
        itmX.SubItems(4) = sTime
        
        '最长等待时间
        l = sNum2(i)
        iHour = l / 3600
        iMinute = (l - iHour * 3600) / 60
        iSecond = l - iHour * 3600 - iMinute * 60
        sTime = TimeSerial(iHour, iMinute, iSecond)
        itmX.SubItems(5) = sTime
        
        '平均服务时间
        If iNum3(i) <> 0 Then
            l = sNum3(i) / iNum3(i)
        Else
            l = 0
        End If
        iHour = l / 3600
        iMinute = (l - iHour * 3600) / 60
        iSecond = l - iHour * 3600 - iMinute * 60
        sTime = TimeSerial(iHour, iMinute, iSecond)
        itmX.SubItems(6) = sTime
        
        '平均等待时间
        l = sNum4(i)
        iHour = l / 3600
        iMinute = (l - iHour * 3600) / 60
        iSecond = l - iHour * 3600 - iMinute * 60
        sTime = TimeSerial(iHour, iMinute, iSecond)
        itmX.SubItems(7) = sTime
    Next i
    
    Erase iNum2()
    ReDim iNum2(UBound(sHead))
    
    '取号人数
    strSQL = "SELECT * FROM CustomerQueue WHERE cq_start_data = '" & DateValue(m_sDate) & _
         "' AND service_queue = '" & m_sService & "' ORDER BY cq_code"
    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
            If Not IsNull(rs!cu_start_time) Then
                sTime1 = TimeValue(rs!cu_start_time)
            End If
            
            For j = 1 To UBound(sHead)
                If TimeValue(sTime1) >= TimeValue(sHead(j - 1)) And TimeValue(sTime1) < TimeValue(sHead(j)) Then
                    iNum2(j) = iNum2(j) + 1
                    Exit For
                End If
            Next j
            rs.MoveNext
        Next i
    End If
    rs.Close
    
    For i = 1 To lsvService.ListItems.Count
        lsvService.ListItems(i).ListSubItems(1).Text = iNum2(i)
        If i = 1 Then
            lsvService.ListItems(i).ListSubItems(3).Text = iNum2(i)
        Else
            j = CInt(lsvService.ListItems(i - 1).ListSubItems(3).Text) - _
                CInt(lsvService.ListItems(i - 1).ListSubItems(2).Text) + iNum2(i)
            If j > 0 Then
                lsvService.ListItems(i).ListSubItems(3).Text = j
            Else
                lsvService.ListItems(i).ListSubItems(3).Text = 0
            End If
        End If
    Next i
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    
    InitListInfo = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmBizStatusList"
    m_tagErrInfo.strErrFunc = "InitListInfo"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number)
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
    
    InitListInfo = False
End Function

'初始化时间管理设置
Private Function Init_Time_Set() As Boolean
    On Error GoTo ERROR_EXIT
    Dim rs As New ADODB.Recordset, cmd As New ADODB.Command
    Dim strSQL As String
    
    '初始化时间设置
    my_time_set.time_use = False
    my_time_set.time_start = "08:00:00"
    my_time_set.time_end = "20:00:00"
    
    '连接数据库
    cmd.ActiveConnection = dbMyDB
    cmd.CommandType = adCmdText
    
    strSQL = "SELECT * FROM VIEW_SET_Time WHERE time_set = 0"
    cmd.CommandText = strSQL
    rs.CursorLocation = adUseClient
    rs.Open cmd, , adOpenStatic, adLockReadOnly
    If Not rs.EOF And rs.RecordCount = 1 Then
        rs.MoveFirst
        my_time_set.time_use = True
        my_time_set.time_start = TimeValue(rs!start_time)
        my_time_set.time_end = TimeValue(rs!end_time)
    End If
    rs.Close
    
    If rs.State = adStateOpen Then rs.Close
    Set rs = Nothing
    Set cmd = Nothing
    strSQL = ""
    
    Init_Time_Set = True
    Exit Function
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmBizStatusList"
    m_tagErrInfo.strErrFunc = "Init_Time_Set"
    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
    Init_Time_Set = False
End Function