Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/vbsock11/chat/server/mainwin.frm

Visual Basic Form | 1995-12-22 | 7.0 KB | 238 lines

VERSION 2.00
Begin Form MainForm
   BackColor       =   &H00C0C0C0&
   Caption         =   "Server"
   ClientHeight    =   6180
   ClientLeft      =   2160
   ClientTop       =   2070
   ClientWidth     =   7080
   Height          =   6870
   Icon            =   MAINWIN.FRX:0000
   Left            =   2100
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   6180
   ScaleWidth      =   7080
   Top             =   1440
   Width           =   7200
   Begin VBServer VBServer1
      Prop10          =   "Click on ""..."" for the About Box ---->"
      ErrorFlag       =   0
      GiveErrorFlag   =   0  'FALSE
      Height          =   420
      Left            =   360
      OpenFlag        =   0
      Port            =   0
      Protocol        =   0  'TCP
      SelectAction    =   0
      SinFamily       =   2  ' AF_INET
      Top             =   5160
      Width           =   420
   End
   Begin SSPanel statusbar
      BevelInner      =   1  'Inset
      Caption         =   " "
      Height          =   375
      Left            =   0
      TabIndex        =   6
      Top             =   5760
      Width           =   7095
   End
   Begin CommandButton Command2
      Caption         =   "&Send"
      Default         =   -1  'True
      Height          =   615
      Left            =   4440
      TabIndex        =   3
      Top             =   120
      Width           =   1575
   End
   Begin TextBox MessageBox
      Height          =   1215
      Left            =   120
      TabIndex        =   4
      Top             =   840
      Width           =   6735
   End
   Begin TextBox RecvBox
      Height          =   2175
      Left            =   240
      MaxLength       =   2000
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   2640
      Width           =   6615
   End
   Begin CommonDialog CMDialog1
      Filter          =   "Host File (Hosts.)|Hosts|All Files (*.*)|*.*"
      Left            =   6360
      Top             =   4920
   End
   Begin CommandButton Command1
      Caption         =   "&Connect"
      Height          =   615
      Left            =   2640
      TabIndex        =   0
      Top             =   4920
      Width           =   1575
   End
   Begin Label Label2
      BackColor       =   &H00C0C0C0&
      Caption         =   "Outgoing..."
      Height          =   255
      Left            =   240
      TabIndex        =   5
      Top             =   480
      Width           =   1215
   End
   Begin Label Label1
      BackColor       =   &H00C0C0C0&
      Caption         =   "In Coming..."
      Height          =   255
      Index           =   1
      Left            =   240
      TabIndex        =   2
      Top             =   2160
      Width           =   1335
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu MnuOptions
      Caption         =   "&Options"
      Begin Menu MnuClear
         Caption         =   "&Clear Windows"
      End
   End
DefInt A-Z
Dim ServerSocket As Integer
Dim CurrentSocket As Integer
Sub Command1_Click ()
    If StartStop = START_MODE Then
    Command1.Caption = "&Disconnect"
    StartStop = STOP_MODE
    RecvBox.Enabled = True
    StartSendListen
    RecvBox.Text = ""
    Else
    Command1.Caption = "&Connect"
    StartStop = START_MODE
    RecvBox.Enabled = False
    StopSendListen
    CurrentSocket = INVALID_SOCKET
    End If
End Sub
Sub Command2_Click ()
Dim LclString As String
Dim LclServer As String
    LclString = MessageBox.Text
    SendString LclString
    MessageBox.Text = ""
    MessageBox.SetFocus
End Sub
Function FindBlank (PStringToSearch As String, PTargetString As String) As Integer
Dim LclString As String
    FindBlank = 0
    StringLen = Len(PStringToSearch)
    For ii = StringLen To 1 Step -1
    LclString = Mid$(PStringToSearch, ii)
    If Asc(LclString) < 32 Then
        FindBlank = ii
        Exit For
    End If
    Next ii
End Function
Sub Form_Load ()
    GlblCount = 0
    ServerSocket = INVALID_SOCKET
    ClientMode = False
    StartStop = START_MODE
    autoflag = 0
    VBServer1.Port = 1234
    VBServer1.SelectAction = FD_ACCEPT Or FD_CLOSE Or FD_READ Or FD_WRITE
    CurrentSocket = INVALID_SOCKET
End Sub
Sub Form_Unload (Cancel As Integer)
    StopSendListen
    ii = WSACleanup()
End Sub
Sub MnuClear_Click ()
    RecvBox.Text = ""
End Sub
Sub mnuExit_Click ()
  End
End Sub
Sub SendString (PMessage As String)
Dim LclLen As Integer
    LclLen = Len(PMessage)
    statusbar.Caption = "CurrentSocket " + Str(CurrentSocket)
    ii = SendSocket(CurrentSocket, PMessage, LclLen, 0)
    statusbar.Caption = "CurrentSocket " + Str(CurrentSocket) + " ii " + Str(ii)
End Sub
Sub StartSendListen ()
    VBServer1.OpenFlag = True
    ServerSocket = VBServer1.SocketNumber
End Sub
Sub StopSendListen ()
   VBServer1.OpenFlag = False
End Sub
Sub VBServer1_Message (MsgVal As Integer, wparam As Integer, lparam As Long)
Dim LclBuf As String
   Static Count As Integer
   Count = Count + 1
    statusbar.Caption = "CurrentSocket = " + Str(CurrentSocket) + " wParam " + Str(wparam) + " " + Str(Count)
    LclBuf = Space$(2000)
    If (wparam = ServerSocket) Then
    ' only FD_ACCEPT
    ii = GetSelectEventSocket(lparam)
    If (ii <> FD_ACCEPT) Then
        statusbar.Caption = "fd_accept Exiting Sub"
        Exit Sub
    End If
    ' we handle only one connection at a time
    If (CurrentSocket <> INVALID_SOCKET) Then
        statusbar.Caption = "Currentsocket Exiting Sub"
        Exit Sub
    End If
    ' try to accept new TCP connection
    ' if we are able to, empty out the
    ' text box data
    CurrentSocket = acceptSocket(ServerSocket)
    statusbar.Caption = "CurrentSocket = " + Str(CurrentSocket)
     ElseIf (wparam = CurrentSocket) Then
    ' socket closed by client
    ii = GetSelectEventSocket(lparam)
    If (ii = FD_CLOSE) Then
        'get ready for next request
        ii = CloseTheSocket(CurrentSocket)
        CurrentSocket = INVALID_SOCKET
        statusbar.Caption = "Closethesocket"
    ElseIf (ii = FD_READ) Then
        ' this assumes that no message exceeds MAX_MSG_SIZE
        LclLen = RecvSocket(CurrentSocket, LclBuf, 300, 0)
        If (LclLen > 0) Then
        LclBuf = Mid$(LclBuf, 1, LclLen)
        If Len(MainForm!RecvBox.Text) > 1250 Then
            RecvBox.Text = LTrim$(Right$(RecvBox.Text, 50)) + LclBuf + Chr$(13) + Chr$(10)
        Else
            RecvBox.Text = RecvBox.Text + LclBuf + Chr$(13) + Chr$(10)
        End If
        LclBuf = RecvBox.Text
        ii = Len(LclBuf)
        RecvBox.SelStart = ii
        LclBuf = ""
        If MainForm.WindowState = MINIMIZED Then
            MainForm.WindowState = NORMAL
            Beep
        End If ' end if windowstate
        End If ' end if lcllen
    End If ' end if fread
     Else
    statusbar.Caption = "CurrentSocket = " + Str(CurrentSocket) + " wParam " + Str(wparam)
     End If ' end else if
End Sub