modwinsock.bas

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

Attribute VB_Name = "modWinsock"
Option Explicit

Dim m_tagErrInfo                As TYPE_ERRORINFO       '错误信息

Public bServer                  As Boolean              '启动服务标志

'maximum ammount of clients

'the maximum clients the server will handle
Public Const server_max_clients = 1000

'the default maximum number of clients
Public Const default_max_clients = 200
Public max_clients As Integer

'port for clients to connect to
Public default_server_port As Long
Public server_port As Long

Public live_connections As Integer

Public Const message_1 = "Server Full"
Public Const message_2 = ""

'this is the data-type for each client.
'it keeps a record of everybody connected
'and also stores data on what socket they
'are using, customize for your needs.
Type client_type
    'socket they are using, 0 if not used
    socket As Integer
    'time they connected
    connected_at As String
    'remember when his last command was
    idle_since As String
End Type

'this creates an array for each possible client
Public client(server_max_clients) As client_type

Public Sub start_server()
    On Error GoTo ERROR_EXIT
    'this just starts the main connection socket up to listen

    'load settings
    set_up_settings

    frmServer.sock(0).LocalPort = server_port
    frmServer.sock(0).Listen

    'show its started in the status
    update_status "*** Server Started *** (" & frmServer.sock(0).LocalIP & ":" & server_port & ")"
    frmServer.stbInfo.Panels(1).Text = "登录用户： " & live_connections
        
    bServer = True
    
    Exit Sub
ERROR_EXIT:
    m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "start_server"
    m_tagErrInfo.strErrFunc = "modWinsock"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & " Unable To Start Server - Port In Use"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

Private Sub set_up_settings()
    On Error Resume Next
    
    'this simply sets up all the settings
    'set the maxmimum number of clients
    max_clients = default_max_clients
    server_port = default_server_port
End Sub

Public Sub close_all_sockets()
    On Error Resume Next
    
    'close down every socket
    '(not designed for restart, deseigned for when sombody closes the program)
    Dim i As Integer
    
    live_connections = 0
    Erase client
    
    For i = 0 To (count_sockets - 1)
        frmServer.sock(i).Close
    Next i
    
    'show its been shutdown.
    update_status "*** Server ShutDown ***"
    frmServer.stbInfo.Panels(1).Text = "登录用户： " & live_connections
    
    bServer = False
End Sub

Private Function count_sockets() As Integer
    On Error Resume Next
    
    'show the number of sockets loaded
    count_sockets = frmServer.sock.Count
End Function

Public Sub new_connection(requestid As Long)
    On Error GoTo ERROR_EXIT
    
    'new connection, so give them a socket
    'socket for new user to have
    Dim use_socket As Integer
    Dim i As Integer
    
    'check if the server is full (with clients) or not
    If live_connections >= max_clients Then
        disallow_connection requestid, message_1
        Exit Sub
    End If
    
    'search the loaded sockets to see if any are long
    For i = 1 To (frmServer.sock.Count - 1)
        If frmServer.sock(i).Tag = "0" Then
            use_socket = i
            GoTo found_sock
        End If
    Next i
    
    'no sockets free so create a new socket
    Dim socket_to_create As Integer
    
    socket_to_create = frmServer.sock.Count
    Load frmServer.sock(socket_to_create)
    use_socket = socket_to_create
        
found_sock:
    'log them in (if no socket found then act as if it were full)
    If login_client(use_socket, requestid) = False Then disallow_connection requestid, message_1: Exit Sub
    
    Exit Sub
ERROR_EXIT:
        m_tagErrInfo.strErrDate = Format(Now, "yyyy-mm-dd hh:mm:ss")
    m_tagErrInfo.strErrFile = "new_connection"
    m_tagErrInfo.strErrFunc = "modWinsock"
    m_tagErrInfo.nErrNum = Err.Number
    m_tagErrInfo.strErrDesc = Error(Err.Number) & " Unable To Start Server - Port In Use"
    If Err.Number <> 0 Then Err.Clear
    modErrorInfo.WriteErrLog m_tagErrInfo
End Sub

Public Sub logout_client(socket As Integer, reason As String)
    On Error Resume Next
    
    'client has disconnected, so close
    'his socket, and blank out his clientid
    'so sombody else can use it.
    'the reason is simply their for status purposes.
    
    'disconnect him
    frmServer.sock(socket).Close
    
    'clear his account (remember its the SOCKET, not clientID)
    client(frmServer.sock(socket).Tag).connected_at = "N/A"
    client(frmServer.sock(socket).Tag).idle_since = "N/A"
    client(frmServer.sock(socket).Tag).socket = "0"
    
    'User logged out (show in status)
    update_status "Client " & frmServer.sock(socket).Tag & " Logged Out (" & reason & ")"
    
    'Unasign his socket
    frmServer.sock(socket).Tag = "0"
    
    'recount live-connections
    live_connections = live_connections - 1
    
    frmServer.stbInfo.Panels(1).Text = "登录用户： " & live_connections
    
    'remove this socket
    Unload frmServer.sock(socket)
    
    'save logout_info
    Login_Info_Save socket, 1
End Sub

Public Function get_clientid(socket As Integer) As Integer
    On Error Resume Next
    'returns the clientid of the client using the specified socket
    get_clientid = frmServer.sock(socket).Tag
End Function

Public Sub disallow_connection(requestid As Long, reason As String)
    On Error Resume Next
    'if you dont want sombody to be allowed to connect,
    'instead of just not envoking the new_connection command
    'envoke this as it lets them connect to a special socket,
    'which'll then tell them the reason they cannot connect
    'and then disconnect them from intself.
    'ideal for 'server full' style messages
    
    'User logged in ok (show in status)
    update_status "Client Rejected (" & reason & ")"
    
    'if no reason given, dont try to tell him it
    If reason = "" Then Exit Sub
    
    
    frmServer.disallow.Close
    frmServer.disallow.Accept requestid
    DoEvents
    
    frmServer.disallow.SendData reason
    DoEvents
    
    frmServer.disallow.Close

End Sub

Private Function login_client(socket As Integer, requestid As Long) As Boolean
    On Error Resume Next
        
    'client connected, so now find him a clientid and setup
    'his own account, returns if he managed to log in or not
    Dim i As Integer
    
    For i = 1 To max_clients
        If client(i).socket = "0" Then
            'found an empty client

            'set client settings
            client(i).connected_at = f_time
            client(i).idle_since = f_time
            client(i).socket = socket

            'tag the socket to remember the clientID
            frmServer.sock(socket).Tag = i

            'connect them on the chosen socket
            frmServer.sock(socket).Close
            frmServer.sock(socket).Accept requestid

            'User logged in ok (show in status)
            update_status "Client " & i & " Logged In (" & frmServer.sock(0).RemoteHostIP & ")"

            'recount live-connections
            live_connections = live_connections + 1
            
            'send welcome message
            send_data socket, message_2
            
            login_client = True
            
            frmServer.stbInfo.Panels(1).Text = "登录用户： " & live_connections
            
            Exit Function
        End If
    Next i
    'All sockets are in use, so return as false
    
End Function