chatserv.frm

来自「vb代码集,收集许多VB网络编程代码」· FRM 代码 · 共 494 行

VERSION 5.00
Begin VB.Form frmChatServer 
   Caption         =   "Chat Server"
   ClientHeight    =   4500
   ClientLeft      =   990
   ClientTop       =   3675
   ClientWidth     =   7995
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4500
   ScaleWidth      =   7995
   Begin VB.Timer Timer2 
      Left            =   3360
      Top             =   1440
   End
   Begin VB.TextBox txtSend 
      Height          =   1335
      Left            =   120
      MaxLength       =   255
      MultiLine       =   -1  'True
      TabIndex        =   13
      Top             =   3000
      Width           =   6495
   End
   Begin VB.CommandButton cmdSendText 
      Caption         =   "Send Text"
      Default         =   -1  'True
      Height          =   615
      Left            =   6840
      TabIndex        =   12
      Top             =   3720
      Width           =   975
   End
   Begin VB.Timer Timer1 
      Left            =   2640
      Top             =   1440
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "Exit"
      Height          =   615
      Left            =   6840
      TabIndex        =   11
      Top             =   2520
      Width           =   975
   End
   Begin VB.TextBox txtThisHost 
      Height          =   285
      Left            =   5280
      TabIndex        =   5
      Text            =   "This Host Name"
      Top             =   600
      Width           =   2535
   End
   Begin VB.TextBox txtPort 
      Height          =   285
      Left            =   5280
      TabIndex        =   4
      Text            =   "2000"
      Top             =   240
      Width           =   2535
   End
   Begin VB.TextBox txtUserName 
      Height          =   285
      Left            =   1320
      TabIndex        =   3
      Text            =   "UserName"
      Top             =   600
      Width           =   2415
   End
   Begin VB.CommandButton DoFinger 
      Caption         =   "Listen"
      Height          =   615
      Left            =   6840
      TabIndex        =   2
      Top             =   1320
      Width           =   975
   End
   Begin VB.TextBox HostResponse 
      BeginProperty Font 
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1455
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   1
      Top             =   1320
      Width           =   6495
   End
   Begin VB.TextBox Host 
      Height          =   285
      Left            =   1320
      TabIndex        =   0
      Text            =   "ChatSvr"
      Top             =   240
      Width           =   2415
   End
   Begin VB.Label Label1 
      Caption         =   "Communication:"
      Height          =   255
      Left            =   120
      TabIndex        =   10
      Top             =   1080
      Width           =   1335
   End
   Begin VB.Label Label6 
      Caption         =   "Server:"
      Height          =   255
      Left            =   120
      TabIndex        =   9
      Top             =   240
      Width           =   855
   End
   Begin VB.Label Label5 
      Caption         =   "This Host:"
      Height          =   255
      Left            =   4080
      TabIndex        =   8
      Top             =   600
      Width           =   1095
   End
   Begin VB.Label lblPort 
      Caption         =   "Port:"
      Height          =   255
      Left            =   4080
      TabIndex        =   7
      Top             =   240
      Width           =   975
   End
   Begin VB.Label lblUserName 
      Caption         =   "User Name;"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   600
      Width           =   1095
   End
End
Attribute VB_Name = "frmChatServer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim formHeightDiff As Integer
Dim formWidthDiff As Integer
Dim Socket2 As Integer
'Dim Socket1() As Integer   ' Code for multiple connections
Dim Sock As Integer
Dim SocketBuffer As sockaddr
'Dim counter As Integer   ' Code for multiple connections




Private Sub cmdExit_Click()
    closesocket Sock
    closesocket Socket2
    End

End Sub

Private Sub cmdSendText_Click()
    Dim RC As Integer
    Dim StartupData As WSADataType
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim RegelUit As String
    Dim Bytes As Integer
    Dim Character As String
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim MustStop As Boolean
    Dim SelectOps As Long

    Regel = ReadLineFromSocket(Socket2)
    HostResponse.Text = HostResponse.Text & "<<< " & Regel & vbCrLf
    '  the following is where i put the ras conditions
    Select Case UCase(Left$(Regel, 4))
        Case "DIAL"
            Regel = "DIAL, Dial request. " & Regel
        Case "RSST"
            Regel = "RSST, Ras Status updatae request. " & Regel
        Case "HNGR"
            Regel = "HNGR, Hang up RAS Request. " & Regel
        Case "QUIT"
            Regel = "QUIT, was requested, socket will terminate " & Regel
            MustStop = True
        Case Else
    End Select
    
    If (MustStop = True) Then
        Regel = txtSend & " " & Regel
    End If

    RegelUit = "Server: " & txtSend & Chr(13) & Chr(10)
    RC = send(Socket2, ByVal RegelUit, Len(RegelUit), 0)
    HostResponse.Text = HostResponse.Text + RegelUit
    
    DoEvents
    If (MustStop = False) Then Exit Sub

    closesocket Socket2
    'closesocket Sock
    ' RC = WSACleanup()
    'End

End Sub

Private Sub Form_Load()
    Me.txtUserName = VBgetusername()
    Me.txtThisHost = VBgethostname
End Sub

Public Function VBgethostname() As String
    Dim tempstr As String
    Dim strlen As Integer, retval As Integer
        Dim StartupData As WSADataType

    retval = WSAStartup(&H101, StartupData)
    If retval = SOCKET_ERROR Then Exit Function
    
    strlen = 128
    tempstr = Space$(strlen)
    retval = 0
    retval = gethostname(tempstr, strlen)
    If retval = 0 Then
        VBgethostname = Left(Trim$(tempstr), (InStr(Trim$(tempstr), Chr(0)) - 1))
    Else
        VBgethostname = "get_hostname: ERROR"
    End If
    tempstr = ""
    
End Function

Public Function VBgetusername() As String
    Dim tempstr As String
    Dim strlen As Integer, retval As Integer
    Dim lname As Long
    strlen = 128
    tempstr = Space$(strlen)
    retval = WNetGetUser(lname, tempstr, 128)
    If retval = 0 Then
        VBgetusername = Trim$(tempstr)
    Else
        VBgetusername = "getusername: ERROR"
    End If
    tempstr = ""
End Function

Private Sub Form_Resize()
    If Me.WindowState <> 1 Then
        'HostResponse.Height = Finger.Height - formHeightDiff
        'HostResponse.Width = Finger.Width - formWidthDiff
    End If
End Sub

Private Sub DoFinger_Click()
    Dim RC As Integer
    Dim StartupData As WSADataType
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim RegelUit As String
    Dim Bytes As Integer
    Dim Character As String '   Receive Buffer comes across for each character
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim MustStop As Boolean
    Dim SelectOps As Long
    Static bfirst As Boolean
    
    HostResponse.Text = "Starting:" & Chr$(13) + Chr$(10)
    RC = WSAStartup(&H101, StartupData)
    If RC = SOCKET_ERROR Then Exit Sub
    
    IPAddr = GetHostByNameAlias(Host)
    If IPAddr = -1 Then
        HostResponse.Text = "Unknown Host: " + Host
        Exit Sub
    End If

    Sock = Socket(PF_INET, SOCK_STREAM, 0)  ' AF_INET of PF_INET?
    If Sock < 0 Then
        HostResponse.Text = "Cannot socket() ..."
        Exit Sub
    End If
    Print "Number of socket() for Sock = "; Sock

    SocketBuffer.sin_family = AF_INET
    SocketBuffer.sin_port = htons(4000) ' alternative method GetServiceByName doesn't seem to work very well ' GetServiceByName("smtp", "TCP")
    SocketBuffer.sin_addr = htonl(INADDR_ANY)

    RC = bind(Sock, SocketBuffer, Len(SocketBuffer))
    If RC Then
        HostResponse.Text = "Cannot bind() ..." + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())

        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If

    RC = listen(Sock, 1) ' Establish a socket to listen for incoming connection.
    'listen (ByVal s As Integer, ByVal backlog As Integer) As Integer
    If RC Then
        HostResponse.Text = "Cannot listen() ..." + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())

        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
    SelectOps = FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
    If WSAAsyncSelect(Sock, Me.hWnd, ByVal 1025, ByVal SelectOps) Then
        If Sock > 0 Then
            RC = closesocket(Sock)
        End If
        MsgBox "Asynchronous error occurred"
        Exit Sub
    End If
    Timer1.Interval = 50
    
    Exit Sub
    
    If bfirst Then
        Do
            DoEvents
            Socket2 = accept(Sock, SocketBuffer, Len(SocketBuffer)) ' This is placed in a timer and checked every 5 seconds
        Loop Until Socket2 > 0
        Print "socket is Socket2"
        If Socket2 < 1 Then
            HostResponse.Text = "Cannot accept() ..." + _
                                Chr$(13) + Chr$(10) + _
                                GetWSAErrorString(WSAGetLastError())
    
            closesocket Sock
            RC = WSACleanup()
            Exit Sub
        End If
        bfirst = False
    End If
    
    Regel = "Connected to Server at: " & Time() & Chr(13) & Chr(10)
    RC = send(Socket2, ByVal Regel, Len(Regel), 0)
    HostResponse.Text = HostResponse.Text + Regel

    Regel = "Attached through port: " & txtPort & " on machine name: " & txtThisHost & Chr(13) & Chr(10)
    RC = send(Socket2, ByVal Regel, Len(Regel), 0)
    HostResponse.Text = HostResponse.Text + Regel

End Sub



Public Function ReadLineFromSocket(Sock As Integer)
    
    Dim Tekens As String * 255
    Dim Aantal As Integer
    Dim Character As String * 1
    Dim Result As String
    Dim Result2 As String
    
    ' Carriage return (vbCr = Chr$(13))
    ' Linefeed (vbLf = Chr$(10))
    Do
        Aantal = recv(Sock, ByVal Tekens, 1, 0)  ' Non-Blocking!
        If (Aantal > 0) Then
            Character = Left$(Tekens, Aantal)
            If (Asc(Character) >= Asc(" ")) Then
                Result = Result & Character
            End If
        End If
        If Character = "" Then
            Character = Chr(13)
        End If
    Loop While ((Aantal > 0) And (Asc(Character) <> 13))   ' looking for carriage return
    
    ReadLineFromSocket = Result
End Function


Private Sub Timer1_Timer()
    Dim RC As Integer
    Dim StartupData As WSADataType
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim RegelUit As String
    Dim Bytes As Integer
    Dim Character As String
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim MustStop As Boolean
    'ReDim Preserve Socket1(counter + 1)   ' Code for multiple connections
    Socket2 = accept(Sock, SocketBuffer, Len(SocketBuffer))
    DoEvents
    
    'If socket1(Counter) > 0 Then   ' Code for multiple connections
    '    counter = counter + 1   ' Code for multiple connections
    If Socket2 > 0 Then   ' comment out this line for Code for multiple connections
        Timer1.Interval = 65000
        Timer2.Interval = 500
        Print "socket is Socket2"
        If Socket2 < 1 Then
            HostResponse.Text = "Cannot accept() ..." + _
                                Chr$(13) + Chr$(10) + _
                                GetWSAErrorString(WSAGetLastError())
            closesocket Sock
            RC = WSACleanup()
            Exit Sub
        End If
    
        Regel = "Connected to Server at: " & Time() & Chr(13) & Chr(10)
        RC = send(Socket2, ByVal Regel, Len(Regel), 0)
        'RC = send(Socket1(counter), ByVal Regel, Len(Regel), 0)
        HostResponse.Text = HostResponse.Text + Regel
    
        Regel = "Attached through port: " & txtPort & " on machine name: " & txtThisHost & Chr(13) & Chr(10)
        RC = send(Socket2, ByVal Regel, Len(Regel), 0)
        'RC = send(Socket1(counter), ByVal Regel, Len(Regel), 0)
        HostResponse.Text = HostResponse.Text + Regel
    End If

End Sub


Private Sub Timer2_Timer()
    Dim RC As Integer
    Dim StartupData As WSADataType
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim RegelUit As String
    Dim Bytes As Integer
    Dim Character As String
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim MustStop As Boolean

    Regel = ReadLineFromSocket(Socket2)
    If Len(Regel) > 0 Then
        HostResponse.Text = HostResponse.Text & "<<< " & Regel & vbCrLf
    End If
    Select Case UCase(Left$(Regel, 4))
        Case "DIAL"
            Regel = "DIAL, Dial request. " & Regel
        Case "RSST"
            Regel = "RSST, Ras Status updatae request. " & Regel
        Case "HNGR"
            Regel = "HNGR, Hang up RAS Request. " & Regel
        Case "QUIT"
            Regel = "QUIT, was requested, socket will terminate " & Regel
            MustStop = True
        Case Else
    End Select
    
    If (MustStop = True) Then
        Regel = "We MUST be STOPPED!"

        RegelUit = "The Client Disconnected: " & Regel & Chr(13) & Chr(10)
        RC = send(Socket2, ByVal RegelUit, Len(RegelUit), 0)
        HostResponse.Text = HostResponse.Text + RegelUit
        DoEvents
    
        closesocket Socket2
        'closesocket Sock
        ' RC = WSACleanup()
    
    
        'End
    End If

End Sub