frmqueue.frm

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

        Case 114                                        '按下 F3
            If cmdAgain.Enabled = True Then
                cmdAgain_Click
            End If
        Case 115                                        '按下 F4
            If cmdAbandon.Enabled = True Then
                cmdAbandon_Click
            End If
        Case 116                                        '按下 F5
            If cmdRecall.Enabled = True Then
                cmdRecall_Click
            End If
        Case 117                                        '按下 F6
            If cmdFirst.Enabled = True Then
                cmdFirst_Click
            End If
        Case 118                                        '按下 F7
            If cmdShift.Enabled = True Then
                cmdShift_Click
            End If
        Case 119                                        '按下 F8
            If cmdChange.Enabled = True Then
                cmdChange_Click
            End If
        Case 120                                        '按下 F9
            If cmdStorage.Enabled = True Then
                cmdStorage_Click
            End If
    End Select
        
End Sub

Private Sub Form_Load()
    On Error GoTo ERROR_EXIT
    Dim iStart As Single
    
    m_bConnect = False
    m_bReLogin = False
    m_bService = False
    
    '连接服务端，采用TCP/IP
    wskConnect.RemoteHost = m_strServer
    wskConnect.RemotePort = m_iPort
    wskConnect.Connect
    
    '等待系统连接，显示动画图标
    iStart = Timer
    Do While Timer < iStart + PauseTime
      DoEvents   ' 将控制让给其他程序。8420
    Loop
    
    '显示矩形框
    m_bDock = True
    If m_bDock = True Then
        timStart.Interval = 50
        Line (0, 0)-(frmQueue.Width, frmQueue.Height), vbCyan, BF
        Get_Windows_Rect
    End If
    
    'HOOK系统菜单处理函数
    procOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SysMenuProc)
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "frmQueue"
    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_Paint()
    On Error Resume Next
       
    '使窗体始终置于最前面
    If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
         SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
              Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
              Me.Height \ Screen.TwipsPerPixelY, 0
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    Dim SureQ As Integer
    
    If m_bReLogin = True Then
        '重复登录关闭主窗口
        Cancel = 0
        Exit Sub
    End If
    
    If m_bLogin = False Then
        '登录失败关闭主窗口
        Cancel = 0
        Exit Sub
    End If
    
    SureQ = MsgBox("真的退出该系统吗(Y/N)？    ", vbYesNo Or vbQuestion, "系统提示")
    If SureQ = vbYes Then
        Cancel = 0
        send_data "STOP" & vbTab & m_strUser & vbTab & m_strServer
    Else
        Cancel = -1
    End If
End Sub

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

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    If m_bReLogin = True Then
        modStartup.Main
        Set frmQueue = Nothing
    End If
End Sub

Private Sub imgControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    
    If m_bDock = False Then Exit Sub
    
    If Is_Move_B Then
        Movex = MyPoint.X - MyRect.Left
        Movey = MyPoint.Y - MyRect.Top
        Is_Movestar_B = True
    End If
End Sub

Private Sub imgControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim dl As Long
    
    If m_bDock = False Then Exit Sub
    
    If Is_Movestar_B Then
        dl = MoveWindow(frmQueue.hWnd, MyPoint.X - Movex, MyPoint.Y - Movey, _
                MyRect.Right - MyRect.Left, MyRect.Bottom, -1)
    End If
End Sub

Private Sub imgControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim dl As Integer
    
    If m_bDock = False Then Exit Sub
    
    dl = GetWindowRect(frmQueue.hWnd, MyRect)
    If MyRect.Top < 20 Then
        Get_Windows_Rect
        Is_Movestar_B = False
    Else
        '停止泊位
        m_bDock = False
        timStart.Enabled = False
        Screen.MousePointer = 0
        modInterface.ControlWindows m_bDock
    End If
        
End Sub

'刷新状态条上的排队人数
Private Sub timInfo_Timer()
    On Error Resume Next
    Quire_Refrsh_Queue
End Sub

Private Sub timStart_Timer()
    On Error Resume Next
    Dim dl As Long
    
    dl = GetCursorPos(MyPoint)
    If (PtInRect(MyRect, MyPoint.X, MyPoint.Y) And _
             frmQueue.Height = max) Or MyPoint.Y <= 3 Then
        frmQueue.BackColor = vbBlue                     '窗体背景颜色(用户可随意改动)
        frmQueue.Height = max
        '判断鼠标指针是否位于窗体拖动区
        If MyPoint.X - MyRect.Left <= 10 Or Is_Movestar_B Then
           Screen.MousePointer = 15
           Is_Move_B = True
        Else
           Screen.MousePointer = 0
           Is_Move_B = False
        End If
    Else
       If Not Is_Movestar_B Then
          frmQueue.Height = 30                          '窗体变小
       End If
    End If
End Sub

'////////////////////////////////////////////////////////////////////////////////////////////////////////
'   通讯处理程序
Private Sub wskConnect_Close()
    On Error Resume Next
    
    wskConnect.Close
    
    Refresh_Info 3
    
    '关闭相关按钮
    cmdArrange.Enabled = False
    cmdAgain.Enabled = False
    cmdAbandon.Enabled = False
    cmdRecall.Enabled = False
    cmdFirst.Enabled = False
    cmdShift.Enabled = False
    cmdChange.Enabled = False
    cmdStorage.Enabled = False
    
    cmdPassword.Enabled = False
    cmdPause.Enabled = False
    
    timInfo.Enabled = False
End Sub

Private Sub wskConnect_Connect()
    On Error Resume Next
    If wskConnect.State <> sckConnected Then
        m_bConnect = False
    Else
        '检查用户身份
        send_data "USER" & vbTab & m_strUser & vbTab & m_strPass & vbTab & m_strServer
    End If
End Sub

Private Sub wskConnect_DataArrival(ByVal bytesTotal As Long)
    On Error GoTo ERROR_EXIT
    Dim new_data As String
    Dim iResult As Integer
    
    'incomming data,to recive it and send it to get decoded
    wskConnect.GetData new_data
    DoEvents
    
    'decode receive code
    decode_data new_data
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "wskConnect_DataArrival"
    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 wskConnect_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    On Error GoTo ERROR_EXIT
    Dim sData As String, sFunction As String
    Dim sPara() As String
    
    wskConnect.GetData sData, vbString
    sFunction = Left$(sData, 4)
    sPara = Split(sData, vbTab)
    
    '根据返回值判断服务方数据
    Select Case sFunction
        Case "USER"         '用户身份认证
            If sPara(1) = "OK" Then
                m_bConnect = True
                If Not Refresh_Info(0) Then GoTo ERROR_EXIT
            Else
                MsgBox "无法验证该用户的身份！", vbOKOnly + vbCritical, "系统错误"
                m_bConnect = False
            End If
        Case Else
        
    End Select
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "wskConnect_Error"
    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

'////////////////////////////////////////////////////////////////////////////////////////////////////
'/
'刷新显示 0 - 刷新用户名称,服务队列 ; 1 - 刷新排队人数
Public Function Refresh_Info(Optional ByVal iMode As Integer = 0) As Boolean
    On Error Resume Next
    
    Select Case iMode
        Case 0
            stbInfo.Panels(2).Text = "服务类型: " & my_service_type.service_name
            stbInfo.Panels(3).Text = "登录用户: " & m_sUserName
            
            Refresh_Info = True
        Case 1
            stbInfo.Panels(4).Text = "等待人数: " & m_iCustomerNum
            
            If m_bService = False Then
                stbInfo.Panels(2).Text = "服务类型: " & my_service_type.service_name
            Else
                stbInfo.Panels(2).Text = "服务客户编号:" & m_sCustomerCode
            End If
            
            Refresh_Info = True
        Case 2
            stbInfo.Panels(1).Text = "已与中心控制台建立连接！"
            stbInfo.Panels(1).ToolTipText = "服务端已与中心控制台连接！"
            
            Refresh_Info = True
        Case 3
            stbInfo.Panels(1).Text = "已与中心控制台断开连接！"
            stbInfo.Panels(1).ToolTipText = "中心控制台关闭连接服务！"
            
            Refresh_Info = True
    End Select
    
End Function

'初始化显示界面按钮状态
Public Function EnableButton(ByVal bMode As Boolean) As Boolean
    On Error Resume Next
    
    If bMode = False And m_bService = False Then
        cmdArrange.Enabled = False
        cmdAgain.Enabled = False
        cmdAbandon.Enabled = False
        cmdRecall.Enabled = False
        cmdFirst.Enabled = False
        cmdShift.Enabled = False
        cmdChange.Enabled = False
        cmdStorage.Enabled = False
    ElseIf bMode = True And m_bService = False Then
        cmdArrange.Caption = "顺呼[F2]"
        cmdArrange.Tag = "0"
        cmdArrange.Enabled = True
        
        cmdRecall.Enabled = True
        cmdFirst.Enabled = True
        cmdChange.Enabled = True
        
        cmdAbandon.Enabled = False
        cmdAgain.Enabled = False
        cmdShift.Enabled = False
        cmdStorage.Enabled = False
    ElseIf bMode = True And m_bService = True Then
        cmdArrange.Caption = "完成[F2]"
        cmdArrange.Tag = "1"
        cmdArrange.Enabled = True
        
        cmdRecall.Enabled = False
        cmdFirst.Enabled = False
        cmdChange.Enabled = False
        
        cmdAbandon.Enabled = True
        cmdAgain.Enabled = True
        cmdShift.Enabled = True
        cmdStorage.Enabled = True
    Else
        EnableButton = False
        Exit Function
    End If
    EnableButton = True
    
End Function