frmserver.frm

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

    mnuServerStop.Enabled = True
    
    imaBack.Picture = img1.ListImages(1).Picture
    
    '创建托盘图标按钮
    With MyNot
        .hIcon = img2.ListImages(1).Picture
        .hWnd = frmServer.hWnd
        .szTip = "MobileServer — 正在运行" & Chr(&H0)
        .uCallbackMessage = WM_USER + 100
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uID = 1
        .cbSize = Len(MyNot)
    End With
    hh = Shell_NotifyIcon(NIM_MODIFY, MyNot)   '修改一个托盘图标

    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "cmdStart_Click"
    m_tagErrInfo.strErrFunc = "frmServer"
    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 cmdStop_Click()
    On Error GoTo ERROR_EXIT
    Dim SureQ As Integer
    Dim hh As Long
    
    SureQ = MsgBox("确实要停止系统服务吗(Y/N)？    ", vbYesNo Or vbQuestion, "系统提示")
    If SureQ = vbNo Then
        Exit Sub
    End If
    
    'when the program ends, close all the sockets.
    close_all_sockets
    
    Erase user()
    
    '修改状态
    cmdStop.Enabled = False
    cmdStart.Enabled = True
    mnuServerStop.Enabled = False
    mnuServerBegin.Enabled = True
    
    imaBack.Picture = img1.ListImages(2).Picture
    
    '修改托盘图标
    With MyNot
        .hIcon = img2.ListImages(2).Picture
        .hWnd = frmServer.hWnd
        .szTip = "MobileServer — 停止运行" & Chr(&H0)
        .uCallbackMessage = WM_USER + 100
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uID = 1
        .cbSize = Len(MyNot)
    End With
    hh = Shell_NotifyIcon(NIM_MODIFY, MyNot)   '修改一个托盘图标
        
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "cmdStop_Click"
    m_tagErrInfo.strErrFunc = "frmServer"
    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 cmdSystemSet_Click()
    On Error Resume Next
    SendMessage Me.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0&
    frmSet.Show
End Sub

Private Sub Form_Load()
    On Error GoTo ERROR_EXIT
    Dim hh As Long
    
    '显示数据库信息
    cboServer.Clear
    cboServer.AddItem g_MyUserDB.strUserDatabase
    cboServer.ListIndex = 0
    
    cmdSystemSet.Enabled = True
    cmdStart.Enabled = False
    cmdStop.Enabled = True
    mnuServerBegin.Enabled = False
    
    chk2.Value = Checked
    imaBack.Picture = img1.ListImages(1).Picture
    
    '将窗口设为总在最前
    SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    ControlWindows False
    
    'start up the server
    start_server
    
    '隐藏显示界面
    gHW = Me.hWnd                           '取得本窗体指针
    Hook                                    '调用钩子函数，将自制消息处理函数钩入Windows的消息循环
    
    '创建托盘图标按钮
    With MyNot
        .hIcon = img2.ListImages(1).Picture
        .hWnd = frmServer.hWnd
        .szTip = "MobileServer — 正在运行" & Chr(&H0)
        .uCallbackMessage = WM_USER + 100
        .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
        .uID = 1
        .cbSize = Len(MyNot)
    End With
    hh = Shell_NotifyIcon(NIM_ADD, MyNot)   '添加一个托盘图标
    trayflag = True                         '托盘图标添加后trayflag为真
    
    'HOOK系统菜单处理函数
    procOld = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SysMenuProc)
    
    '设定定时器,刷新排队人数
    timInfo.Interval = 10000
    timInfo.Enabled = True
    
    frmServer.stbInfo.Panels(2).Text = "服务人数： " & sock.Count
    
    bDisplay = True
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "Form_Load"
    m_tagErrInfo.strErrFunc = "frmServer"
    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_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    Dim SureQ As Integer
    Dim hh As Long
    
    SureQ = MsgBox("真的退出该系统吗(Y/N)？    ", vbYesNo Or vbQuestion, "系统提示")
    If SureQ = vbYes Then
        Cancel = 0
    Else
        Cancel = -1
    End If
    If Cancel = 0 Then
        If trayflag = True Then                                 '如果托盘图标仍在，删除托盘图标
            With MyNot
                .hIcon = frmServer.Icon                         '托盘图标指针指向窗口的图标
                .hWnd = frmServer.hWnd                          '窗体指针
                .szTip = ""                                     '弹出提示字符串，删除时应为空
                .uCallbackMessage = WM_USER + 100               '对应程序定义的消息
                .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE    '图标标志
                .uID = 1                                        '图标识别符
                .cbSize = Len(MyNot)                            '计算结构实例MyNot的长度
            End With
            hh = Shell_NotifyIcon(NIM_DELETE, MyNot)            '删除该托盘图标
            trayflag = False                                    '托盘图标删除后trayflag为假
        End If
        
        UnHook                                                  '退出消息循环
    End If
End Sub

Private Sub Form_Resize()
    On Error Resume Next
        
    If bDisplay = True Then
        SendMessage Me.hWnd, WM_SYSCOMMAND, SC_CLOSE, 0&
        bDisplay = False
        Exit Sub
    End If
    If Me.WindowState = 1 Then Exit Sub
    If chk2.Value = Unchecked Then
        Me.Height = H_OLD
        status.Visible = False
    Else
        Me.Height = H_NEW
        status.Visible = True
    End If
    Me.Width = 5190
End Sub

Private Sub Form_Terminate()
    On Error Resume Next
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error GoTo ERROR_EXIT
    
    'start connect Datebase
    
    
    'when the program ends, close all the sockets.
    If bServer = True Then close_all_sockets
    
    Unload Me
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "Form_Unload"
    m_tagErrInfo.strErrFunc = "frmServer"
    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 mnuAbout_Click()
    On Error Resume Next
    frmAbout.Show
End Sub

Private Sub mnuOpenShow_Click()
    On Error Resume Next
    frmServer.Show
End Sub

Private Sub mnuQuit_Click()
    On Error Resume Next
    Unload Me                                               '卸载窗体
End Sub

Private Sub mnuServerBegin_Click()
    On Error Resume Next
    cmdStart_Click
End Sub

Private Sub mnuServerStop_Click()
    On Error Resume Next
    cmdStop_Click
End Sub

Private Sub mnuSystemSet_Click()
    On Error Resume Next
    frmSet.Show
End Sub

'刷新状态条上的排队人数
Private Sub timInfo_Timer()
    On Error Resume Next
    frmServer.stbInfo.Panels(2).Text = "服务人数： " & sock.Count
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'sock 事件处理
Private Sub sock_Close(Index As Integer)
    'Log out clients once they have quit
    logout_client Index, "Connection long"
End Sub

Private Sub sock_DataArrival(Index As Integer, ByVal bytesTotal As Long)
    'incomming data,to recive it and send it to get decoded
    Dim new_data As String
    
    If bytesTotal < 4 Then
        Debug.Print "Not All Data!"
    Else
        sock(Index).GetData new_data
        Debug.Print new_data;
        
        DoEvents
        
        decode_data new_data, Index
    End If
    
End Sub

Private Sub sock_Error(Index As Integer, 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)
    'Log out clients if error on port
    logout_client Index, "Error - " & Description
End Sub

Private Sub sock_ConnectionRequest(Index As Integer, ByVal requestid As Long)
    'Login a new user on a connection request
    
    If Index = "0" Then
        'show in status
        'update_status ">> Incomming Connection Request <<"
        
        'login new user
        new_connection requestid
        DoEvents
    End If
End Sub